Related
The code I have takes cells containing the delimiter (; ) from a column, and creates new rows (everything except the column is duplicated) to separate those values.
What I have
I need this for multiple columns in my data, but I don't want 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.
What I want
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
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
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
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...
I have data in Column A that looks like this:
A
B
A
B
B
B
A
B
A
B
Some points:
All A's must have at least one B. All A's have a B, all B's have an A. (it's an accounting system - it requires this).
Any A can have as many B's as needed.
After each A.B[n] combo, we need a C.
The C must be an inserted row. Sorting and Filtering is not allowed (A, B, and C are variables that aren't replaced with alphabetical characters like seen here).
The code should not insert a C above the first A.
Expected output:
A
B
C
A
B
B
B
C
A
B
C
A
B
C
I've already looked at this: Excel: Insert new line every x rows with content according to a pattern
but the pattern is based on a known 27-line insertion. This has no guaranteed pattern in my problem.
Being a forward thinker, I used multiple Do loops.
Sub InsertCs()
Application.ScreenUpdating = False
Const A As String = "A", B As String = "B", C As String = "C"
Dim r As Long, r2 As Long
With Worksheets("Sheet1")
Do
r = r + 1
If .Cells(r, "A").Value = A And .Cells(r, "A").Offset(1).Value = B Then
r2 = r + 1
Do
r2 = r2 + 1
Loop Until Cells(r2, "A").Value = "" Or Cells(r2, "A").Value = A Or Cells(r2, "A").Value = C
If Not Cells(r2).Value = C Then
.Rows(r2).Insert xlDown
.Cells(r2, "A").Value = C
End If
r = r2
End If
Loop Until Cells(r, "A").Value = ""
End With
End Sub
Try
Sub test()
Dim vDB, vR()
Dim A, B, C
Dim i As Long, r As Long, n As Long
A = "A"
B = "B"
C = "C"
vDB = Range("a1").CurrentRegion
r = UBound(vDB, 1)
n = 1
ReDim Preserve vR(1 To n)
vR(1) = vDB(1, 1)
For i = 2 To r
If vDB(i - 1, 1) = B And vDB(i, 1) = A Then
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = C
End If
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = vDB(i, 1)
Next i
If vR(n) = B Then
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = C
End If
Range("c1").CurrentRegion.Clear
Range("c1").Resize(n, 1) = WorksheetFunction.Transpose(vR)
End Sub
If you want multi column then
Sub test2()
Dim vDB, vR(), vS()
Dim A, B, C
Dim i As Long, r As Long, n As Long
Dim col As Integer
Dim Ws As Worksheet
A = "A"
B = "B"
C = "C"
vDB = Range("a1").CurrentRegion
r = UBound(vDB, 1)
col = UBound(vDB, 2)
n = 1
ReDim Preserve vR(1 To col, 1 To n)
For j = 1 To col
vR(j, n) = vDB(1, j)
Next j
For i = 2 To r
If vDB(i - 1, 1) = B And vDB(i, 1) = A Then
n = n + 1
ReDim Preserve vR(1 To col, 1 To n)
vR(1, n) = C
End If
n = n + 1
ReDim Preserve vR(1 To col, 1 To n)
For j = 1 To col
vR(j, n) = vDB(i, j)
Next j
Next i
If vR(1, n) = B Then
n = n + 1
ReDim Preserve vR(1 To col, 1 To n)
vR(1, n) = C
End If
Set Ws = Sheets.Add 'Sheets("Result")
With Ws
.Range("a1").CurrentRegion.Clear
.Range("a1").Resize(n, col) = WorksheetFunction.Transpose(vR)
End With
End Sub
1. All A's must have at least one B.
Since all A's must have at least one B, your logic seems to boil down to: If current cell is not B and cell directly above is B then insert row and paste C.
Option Explicit
Sub Macro1()
Dim i As Long
Dim a As Variant, b As Variant, c As Variant
a = "A"
b = "B"
c = "C"
With Worksheets("sheet3")
For i = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 To 3 Step -1
Select Case .Cells(i - 1, "A").Value2
Case b
If .Cells(i, "A").Value2 <> b Then
.Rows(i).Insert
.Cells(i, "A") = c
End If
End Select
Next i
End With
End Sub
Sub MultipleSearch()
Dim rng As Range
Dim cll As Range
Dim lrow As Long
lrow = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("A1:A" & lrow)
Cells(lrow + 1, 1) = "C"
For i = rng.Cells.Count To 2 Step -1
If rng.Item(i) = "A" Then
Rows(i).Insert
Cells(i, 1) = "C"
End If
Next
End Sub
Try this simple code. It will loop from the last cell in column A and if there is a variable varA then varB, it will insert a row and add varC. Assign your variables as needed.
Dim varA As Variant, varB As Variant, varC As Variant
Dim Rng As Range, i As Long, lRow As Long
varA = "A"
varB = "B"
varC = "C"
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = lRow To 2 Step -1
If Cells(i, 1).Value = varB And Cells(i, 1).Offset(-1).Value = varA Then
Cells(i, 1).Offset(1).EntireRow.Insert
Cells(i, 1).Offset(1).Value = varC
End If
Next i
Using Find and some do loops is a way to do it...
Sub InsertC()
Application.ScreenUpdating = False
Dim Data As Range: Set Data = Worksheets("Sheet1").Range("A:A")
Dim FirstCell As Range: Set FirstCell = Data.Find("A", LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, SearchOrder:=xlByRows)
Dim NextCell As Range, ACell As Range: Set ACell = FirstCell
If Not ACell Is Nothing Then
Do
Set NextCell = ACell
Do While NextCell.Offset(1, 0) = "B"
Set NextCell = NextCell.Offset(1, 0)
Loop
If Not ACell = NextCell Then
NextCell.Offset(1, 0).Insert Shift:=xlDown
NextCell.Offset(1, 0) = "C"
End If
Set ACell = Data.Find("A", After:=NextCell, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, SearchOrder:=xlByRows)
Loop While ACell.Address <> FirstCell.Address
End If
Application.ScreenUpdating = True
End Sub
I have a spreadsheet containing a column of numbers.
For every value within the reference column, I need the to excel to produce a row of number in the adjacent column with values starting from the number 1, incrementally increasing by 1 and ending once the reference value is reach. This then needs to be repeated for the next value in the reference column and so on, continuing to expand in the adjacent column.
Below is an example of the reference column containing 3 values and what i did manually adjacent. Can some please help me write function in VBA so that i dont need to do this manually.
Thanks for the help in advanced.
Sub main()
Dim cell As Range, i As Long
For Each cell In Range("I2", Cells(Rows.Count, "I").End(xlUp))
For i = 1 To cell.Value
Cells(Rows.Count, "J").End(xlUp).Offset(1).Value = i
Next
Next
End Sub
Larger grouped series would benefit from an array.
sub main()
dim i as long, j as long, k as long, vals as variant
redim vals(1 to application.sum(range(cells(2, "i"), cells(rows.count, "i").end(xlup))), 1 to 1)
for i=2 to cells(rows.count, "i").end(xlup).row
for j=1 to cells(i, "i").value2
k=k+1
vals(k, 1) = j
next j
next i
cells(2, "j").resize(ubound(vals, 1), ubound(vals, 2)) = vals
end sub
This doesn't allow you to go beyond last Excel row
Option Explicit
Public Sub ExpandReferenceNumbers()
Const REF_COL = 9 'I
Dim arr As Variant, lr As Long, i As Long, j As Long, k As Long
Dim maxRows As Long, maxVal As Long, maxXLRows As Long
maxXLRows = Rows.Count
lr = Sheet1.Cells(maxXLRows, REF_COL).End(xlUp).Row
arr = Sheet1.Range(Sheet1.Cells(2, REF_COL), Sheet1.Cells(lr, REF_COL))
For i = 1 To lr - 1
maxRows = maxRows + arr(i, 1)
Next
If maxRows > maxXLRows Then maxRows = maxXLRows - 2
arr = Sheet1.Range(Sheet1.Cells(2, REF_COL), Sheet1.Cells(maxRows + 1, REF_COL + 1))
k = 1
For i = 1 To lr
For j = 1 To arr(i, 1)
If k + j - 1 > maxRows Then Exit For
arr(k + j - 1, 2) = j
Next
k = k + arr(i, 1)
Next
Sheet1.Range(Sheet1.Cells(2, REF_COL), Sheet1.Cells(maxRows + 1, REF_COL + 1)) = arr
End Sub
Result
Or with arrays
Option Explicit
Sub test()
Dim arr(), i As Long, j As Long, output As String
With ThisWorkbook.Worksheets("Sheet1")
arr = .Range("I2", .Cells(.Rows.Count, "I").End(xlUp)).Value
For i = LBound(arr, 1) To UBound(arr, 1)
j = 0
Do While j < arr(i, 1)
j = j + 1
output = output & CStr(j) & ","
Loop
Next i
.Range("J2").Resize(UBound(Split(output, ",")), 1) = Application.WorksheetFunction.Transpose(Split(output, ","))
End With
End Sub
Column A contains the labels or outcome value, Columns B-N contain varying lengths of comma separated values, but range for each column is the same (i.e., 1-64). The goal is to covert to a new table with Column A representing the value range (1-64) and Columns B-N the labels/outcome from the original table.
A semi-related solution was sought here, but without use of macros.
I will let you to modify this code,
Sub splitThem()
Dim i As Long, j As Long, k As Long, x As Long
x = 1
Sheets.Add.Name = "newsheet"
For j = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Cells(Rows.Count, 2).End(xlUp).Row
If Cells(i, j) <> "" Then
For k = 1 To Len(Cells(i, j)) - Len(Replace(Cells(i, j), ",", "")) + 1
Sheets("newsheet").Cells(x, j) = Cells(i, 1)
x = x + 1
Next k
End If
Next i
x = 1
Next j
End Sub
Try this code.
Sub test()
Dim vDB, vR()
Dim vSplit, v As Variant
Dim Ws As Worksheet
Dim i As Long, n As Long, j As Integer, c As Integer
vDB = Range("a2").CurrentRegion
n = UBound(vDB, 1)
c = UBound(vDB, 2)
ReDim vR(1 To 64, 1 To c)
For i = 1 To 64
vR(i, 1) = i
Next i
For i = 2 To n
For j = 2 To c
vSplit = Split(vDB(i, j), ",")
For Each v In vSplit
vR(v, j) = vDB(i, 1)
Next v
Next j
Next i
Set Ws = Sheets.Add '<~~ replace your sheet : Sheets(2)
With Ws
For i = 1 To c
.Range("b1")(1, i) = "COND" & i
Next i
.Range("a2").Resize(64, c) = vR
End With
End Sub
I have two columns in Excel with different values:
A 1
B 2
C 3
Now, I would need to pair each cell of first column with each cell of second column. So it would look like this:
A 1
A 2
A 3
B 1
B 2
B 3
C 1
C 2
C 3
Do you know how can I do this please?
Thank you heaps
With data in columns A and B try this short macro:
Sub MakeCombinations()
Dim Na As Long, Nb As Long
Dim i As Long, j As Long, K As Long
Dim rc As Long
K = 1
rc = Rows.Count
Na = Cells(rc, 1).End(xlUp).Row
Nb = Cells(rc, 2).End(xlUp).Row
For i = 1 To Na
For j = 1 To Nb
Cells(K, 3) = Cells(i, 1)
Cells(K, 4) = Cells(j, 2)
K = K + 1
Next j
Next i
End Sub
EDIT#1:
To do this without VBA, in C1 enter:
=INDEX(A:A,ROUNDUP(ROW()/COUNTA(B:B),0),1)
and copy down and in D1 enter:
=INDEX(B:B,MOD(ROW()-1,COUNTA(B:B))+1,1)
and copy down:
I modify Gary's answer with array. Not tested due to my Mac without Excel.
Sub MakeCombinations()
Dim Ary_a As Variant, Ary_b As Variant, Ary as Variant
Dim i As Long, j As Long
Ary_a = range(Cells(rows.count, 1).End(xlUp).Row, 1).value
Ary_b = range(Cells(rows.count, 2).End(xlUp).Row, 2).value
For i = lbound(ary_a) To ubound(ary_a)
For j = lbound(ary_b) To ubound(ary_b)
if not isarray(ary) then
redim ary(1, 0)
else
redim preserve ary(1, ubound(ary, 2)+1)
end if
ary(0, ubound(ary, 2)) = ary_a(i)
ary(1, ubound(ary, 2)) = ary_b(j)
Next j
Next i
cells(1, 4).resize(ubound(ary, 2)+1, ubound(ary, 1)+1).value = application.transpose(ary)
End Sub