AW: Datei geschickt
04.03.2011 10:47:22
Rudi
Hallo,
du meinst M statt L, oder?
Sub VerbundeneZellen_Loeschen()
Dim rngC As Range, arrTmpB, rngDel As Range, i As Integer, sTmpB As String, arrTmpM, sTmpM
Const sDelim As String = " | "
Application.ScreenUpdating = False
prcMergeCells
For Each rngC In Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
If rngC.MergeArea.Cells.Count > 1 Then
If rngC.Address = rngC.MergeArea.Cells(1).Address Then
sTmpB = ""
sTmpM = ""
arrTmpB = rngC.MergeArea.Offset(, 1).Resize(rngC.MergeArea.Cells.Count)
arrTmpM = rngC.MergeArea.Offset(, 12).Resize(rngC.MergeArea.Cells.Count)
For i = 1 To UBound(arrTmpB) - 1
If arrTmpB(i, 1) "" Then sTmpB = sTmpB & arrTmpB(i, 1) & sDelim
If arrTmpM(i, 1) "" Then sTmpM = sTmpM & arrTmpM(i, 1) & sDelim
Next
sTmpB = sTmpB & arrTmpB(i, 1)
sTmpM = sTmpB & arrTmpM(i, 1)
rngC.Offset(, 1) = sTmpB
rngC.Offset(, 12) = sTmpM
If rngDel Is Nothing Then
Set rngDel = rngC.Cells(2).Resize(rngC.MergeArea.Cells.Count - 1)
Else
Set rngDel = Union(rngDel, rngC.Cells(2).Resize(rngC.MergeArea.Cells.Count - 1))
End If
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
'Text in Spalten für Spalten C bis E aufgrund Fehler in Zelle (Text statt Zahl formatiert)
TextInSpalten
End Sub
TextInSpalten ohne Select und mit Schleife:
Private Sub TextInSpalten()
Dim i As Long
For i = 3 To 5
Columns(i).TextToColumns Destination:=Cells(1, i), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Next i
End Sub
Gruß
Rudi
Traurig, dass es in so 'ner großen Bude niemanden gibt, der das kann.