I need some help on modifying this excel VBA. The code that I have now works in taking cells containing the delimiter (; ) from a column, and creating new rows (everything else except the column is duplicated) to separate those values.
However, I need to do this for multiple columns in my data, but I don't the data to overlap (ex: for 3 columns, I want there to be only one value per row in those 3 columns). It would be ideal if I could select multiple columns instead of only one as my code does now.
I hope this makes sense, and let me know if I need to clarify anything. I am not familiar with the VBA language at all. Could someone help me modify my code so it works in this way?
My code is here
Sub splitByCol()
Dim r As Range, i As Long, ar
Set r = Worksheets("Sheet").Range("J2000").End(xlUp)
Do While r.Row > 1
ar = Split(r.Value, "; ")
If UBound(ar) >= 0 Then r.Value = ar(0)
For i = UBound(ar) To 1 Step -1
r.EntireRow.Copy
r.Offset(1).EntireRow.Insert
r.Offset(1).Value = ar(i)
Next
Set r = r.Offset(-1)
Loop
End Sub
CodePudding user response：
Try this code
Sub Test()
Dim a, x, e, i As Long, ii As Long, iii As Long, k As Long
a = Range("A1").CurrentRegion.Value
ReDim b(1 To 1000, 1 To UBound(a, 2))
For i = LBound(a) To UBound(a)
For ii = 2 To 3
x = Split(a(i, ii), "; ")
For Each e In x
k = k 1
b(k, 1) = k
b(k, 2) = IIf(ii = 2, e, Empty)
b(k, 3) = IIf(ii = 3, e, Empty)
b(k, 4) = a(i, 4)
Next e
Next ii
Next i
Range("A5").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
CodePudding user response：
I'd go this way
Sub SplitByCol()
With Worksheets("Sheet")
With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
Dim firstColValues As Variant
firstColValues = .Value
Dim secondColValues As Variant
secondColValues = .Offset(, 1).Value
Dim thirdColValues As Variant
thirdColValues = .Offset(, 2).Value
.Offset(, -1).Resize(, 4).ClearContents
End With
Dim iRow As Long
For iRow = LBound(firstColValues) To UBound(firstColValues)
Dim currFirstColValues As Variant
currFirstColValues = Split(firstColValues(iRow, 1), "; ")
Dim currSecondColValues As Variant
currSecondColValues = Split(secondColValues(iRow, 1), "; ")
With .Cells(.Rows.Count, "C").End(xlUp).Offset(1, -1)
With .Resize(UBound(currFirstColValues) 1)
.Value = currFirstColValues
.Offset(, 2).Value = thirdColValues(iRow, 1)
End With
End With
With .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 1)
With .Resize(UBound(currSecondColValues) 1)
.Value = currSecondColValues
.Offset(, 1).Value = thirdColValues(iRow, 1)
End With
End With
Next
End With
End Sub
Follow the code step by step by pressing F8 while the cursor is in any code line in the VBA IDE and watch what happens in the Excel user interface
EDIT
adding edited code for a more "parametric" handling by means of a helper function
Sub SplitByCol()
With Worksheets("Sheet")
With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
Dim firstColValues As Variant
firstColValues = .Value
Dim secondColValues As Variant
secondColValues = .Offset(, 1).Value
Dim thirdColValues As Variant
thirdColValues = .Offset(, 2).Value
.Offset(, -1).Resize(, 4).ClearContents
End With
Dim iRow As Long
For iRow = LBound(firstColValues) To UBound(firstColValues)
Dim currFirstColValues As Variant
currFirstColValues = Split(firstColValues(iRow, 1), "; ")
Dim currSecondColValues As Variant
currSecondColValues = Split(secondColValues(iRow, 1), "; ")
WriteOne .Cells(.Rows.Count, "C").End(xlUp).Offset(1), _
currFirstColValues, thirdColValues(iRow, 1), _
-1, 2
WriteOne .Cells(.Rows.Count, "B").End(xlUp).Offset(1), _
currSecondColValues, thirdColValues(iRow, 1), _
1, 1
Next
End With
End Sub
Sub WriteOne(refCel As Range, _
currMainColValues As Variant, thirdColValue As Variant, _
mainValuesOffsetFromRefCel As Long, thirdColValuesOffsetFromRefCel As Long)
With refCel.Offset(, mainValuesOffsetFromRefCel)
With .Resize(UBound(currMainColValues) 1)
.Value = currMainColValues
.Offset(, thirdColValuesOffsetFromRefCel).Value = thirdColValue
End With
End With
End Sub
CodePudding user response：
Please, use the next code. It uses arrays and should be very fast for big ranges to be processed, working mostly in memory:
Sub testSplitInsert()
Dim sh As Worksheet, lastR As Long, arr, arrSp, arrFin, i As Long, j As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
arr = sh.Range("B1:D" & lastR).Value
ReDim arrFin(1 To UBound(arr) * 10, 1 To 3) 'maximum to keep max 10 rows per each case
k = 1 'initialize the variable to load the final array
For i = 1 To UBound(arr)
arrSp = Split(Replace(arr(i, 1)," ",""), ";") 'trim for the case when somebody used Red;Blue, instead of Red; Blue
For j = 0 To UBound(arrSp)
arrFin(k, 1) = arrSp(j): arrFin(k, 3) = arr(i, 3): k = k 1
Next j
arrSp = Split(Replace(arr(i, 1)," ",""), ";")
For j = 0 To UBound(arrSp)
arrFin(k, 2) = arrSp(j): arrFin(k, 3) = arr(i, 3): k = k 1
Next j
Next
sh.Range("G1").Resize(k - 1, 3).Value = arrFin
End Sub
It processes the range in columns "B:D" and returns the result in columns "G:I". It can be easily adapted to process any columns range and return even overwriting the existing range, but this should be done only after checking that it return what you need...