Sub StringAufteilenA()
'Aufteilen von Strings mit Zeilenumbruch in einer Zelle
'auf einzelne Zellen(mit Nachbarzelle)
'Zellen (Spalte 1) markieren
Dim str1 As Variant, str2 As Variant
Dim varA() As Variant, varB() As Variant
Dim intC As Integer, intA As Integer, intB As Integer
Dim rng As Range
Dim lngRow As Long, intCol As Integer
If Selection.Columns.Count > 1 Then Exit Sub
lngRow = Selection(1).Row
intCol = Selection.Column
For Each rng In Selection
str1 = Split(rng, Chr(10))
str2 = Split(rng.Offset(, 1), Chr(10))
intB = intB + UBound(str1) + 1
For intC = 0 To UBound(str1)
ReDim Preserve varA(intB)
varA(intA) = str1(intC)
ReDim Preserve varB(intB)
varB(intA) = str2(intC)
intA = intA + 1
Next
Next
For intC = 0 To UBound(varA)
Cells(intC + lngRow, intCol) = varA(intC)
Cells(intC + lngRow, intCol + 1) = varB(intC)
Next
End Sub
Gruß Sepp
Ein kluger Mann macht nicht alle Fehler selbst.
Er lässt auch anderen eine Chance.
(Sir Winston Churchill)
Gruß Sepp
Ein kluger Mann macht nicht alle Fehler selbst.
Er lässt auch anderen eine Chance.
(Sir Winston Churchill)
Sub StringAufteilenA()
'Aufteilen von Strings mit Zeilenumbruch in einer Zelle
'auf einzelne Zellen(mit Nachbarzellen 3 links + 3 rechts)
'Zellen (Spalte 1) markieren
Dim strA As Variant, strB As Variant, strC As Variant, strD As Variant
Dim strX As Variant, strY As Variant, strZ As Variant
Dim varA() As Variant, varB() As Variant, varC() As Variant, varD() As Variant
Dim varX() As Variant, varY() As Variant, varZ() As Variant
Dim intC As Integer, intA As Integer, intB As Integer
Dim rng As Range
Dim lngRow As Long, intCol As Integer, intRC As Integer
If Selection.Columns.Count > 1 Then Exit Sub
lngRow = Selection(1).Row
intCol = Selection.Column
intRC = Selection.Rows.Count
For Each rng In Selection
strA = Split(rng, Chr(10))
strB = Split(rng.Offset(0, 1), Chr(10))
strC = Split(WorksheetFunction.Rept(rng.Offset(0, 2) & vbLf, UBound(strA) + 1), Chr(10))
strD = Split(WorksheetFunction.Rept(rng.Offset(0, 3) & vbLf, UBound(strA) + 1), Chr(10))
strX = Split(WorksheetFunction.Rept(rng.Offset(0, -1) & vbLf, UBound(strA) + 1), Chr(10))
strY = Split(WorksheetFunction.Rept(rng.Offset(0, -2) & vbLf, UBound(strA) + 1), Chr(10))
strZ = Split(WorksheetFunction.Rept(rng.Offset(0, -3) & vbLf, UBound(strA) + 1), Chr(10))
intB = intB + UBound(strA) + 1
For intC = 0 To UBound(strA)
ReDim Preserve varA(intB)
varA(intA) = strA(intC)
ReDim Preserve varB(intB)
varB(intA) = strB(intC)
ReDim Preserve varC(intB)
varC(intA) = strC(intC)
ReDim Preserve varD(intB)
varD(intA) = strD(intC)
ReDim Preserve varX(intB)
varX(intA) = strX(intC)
ReDim Preserve varY(intB)
varY(intA) = strY(intC)
ReDim Preserve varZ(intB)
varZ(intA) = strZ(intC)
intA = intA + 1
Next
Next
Rows(intRC + lngRow & ":" & lngRow + UBound(varA)).Insert Shift:=xlDown
For intC = 0 To UBound(varA)
Cells(intC + lngRow, intCol) = varA(intC)
Cells(intC + lngRow, intCol + 1) = varB(intC)
Cells(intC + lngRow, intCol + 2) = varC(intC)
Cells(intC + lngRow, intCol + 3) = varD(intC)
Cells(intC + lngRow, intCol - 1) = varX(intC)
Cells(intC + lngRow, intCol - 2) = varY(intC)
Cells(intC + lngRow, intCol - 3) = varZ(intC)
Next
End Sub
Gruß Sepp
Ein kluger Mann macht nicht alle Fehler selbst.
Er lässt auch anderen eine Chance.
(Sir Winston Churchill)
Ein kluger Mann macht nicht alle Fehler selbst.
Er lässt auch anderen eine Chance.
(Sir Winston Churchill)