AW: Zellen trennen wieder zusammenfügen
25.09.2017 09:40:24
yummi
Hallo Peter,
ich habe bei der Teilen Funktion eine weitere Funktionalität hinzugefügt und merke mir jetzt wo ein Komma war. Die neue Funktionalität nutze ich beim Zusammenfügen
Nimm mal bitte folgenden Code und probier mal
Sub Teilen()
Dim TB, LR As Double, i As Double
Set TB = Sheets("Tabelle1")
LR = TB.Cells(TB.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte
TB.Cells(2, 3).Resize(LR - 1, 8).ClearContents
TB.Cells(2, 1).Resize(LR - 1, 1).TextToColumns Destination:=TB.Range("C2"), DataType:= _
xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo:= _
Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7 _
, 1)), TrailingMinusNumbers:=True
For i = 2 To LR
If Right(TB.Cells(i, 4), 1) "." Then 'Prüfen auf Dr. etc
TB.Cells(i, 4).Insert Shift:=xlToRight
End If
If TB.Cells(i, 5) "" Then
If InStr(1, TB.Cells(i, 5).Value, ",", vbTextCompare) 0 Then
TB.Cells(i, 2).Value = TB.Cells(i, 2).Value & "5"
End If
TB.Cells(i, 5) = Replace(TB.Cells(i, 5), ",", "")
If InStr(TB.Cells(i, 5), "(") > 0 Then
TB.Cells(i, 5).Resize(1, 2).Insert Shift:=xlToRight
ElseIf InStr(TB.Cells(i, 5), "Raum") > 0 Then
TB.Cells(i, 5).Insert Shift:=xlToRight
End If
End If
If TB.Cells(i, 6) "" Then
If InStr(1, TB.Cells(i, 6).Value, ",", vbTextCompare) 0 Then
TB.Cells(i, 2).Value = TB.Cells(i, 2).Value & "6"
End If
TB.Cells(i, 6) = Replace(TB.Cells(i, 6), ",", "")
If InStr(TB.Cells(i, 6), "(") > 0 Then
TB.Cells(i, 6).Insert Shift:=xlToRight
ElseIf InStr(TB.Cells(i, 6), "Raum") > 0 Then
TB.Cells(i, 6).Resize(1, 2).Insert Shift:=xlToRight
End If
End If
If TB.Cells(i, 7) "" Then
If InStr(1, TB.Cells(i, 7).Value, ",", vbTextCompare) 0 Then
TB.Cells(i, 2).Value = TB.Cells(i, 2).Value & "7"
End If
TB.Cells(i, 7) = Replace(TB.Cells(i, 7), ",", "")
If InStr(TB.Cells(i, 7), "Raum") > 0 Then
TB.Cells(i, 7).Insert Shift:=xlToRight
End If
End If
Next
End Sub
Sub Zusammenfuehren_mitKomma()
Dim TB, LR As Double, i As Double
Dim s As Integer
Dim strGesamt As String
Set TB = Sheets("Tabelle1")
LR = TB.Cells(TB.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte
For i = 2 To LR
strGesamt = ""
For s = 3 To 10
If s = 3 Then
strGesamt = strGesamt & TB.Cells(i, s).Value
Else
strGesamt = strGesamt & " " & TB.Cells(i, s).Value
End If
If InStr(1, TB.Cells(i, 2).Value, CStr(s), vbTextCompare) 0 Then
strGesamt = strGesamt & ","
End If
Next s
TB.Cells(i, 12).Value = strGesamt
Next i
End Sub
Gruß
yummi