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
Related
This is my current format
I would like a formula so that the output is like this
With data in columns A and B, try this short macro:
Sub SplitList()
Dim i As Long, j As Long, N As Long
Dim v As String, arr, a
N = Cells(Rows.Count, "A").End(xlUp).Row
j = 1
For i = 1 To N
v = Cells(i, 1).Value
arr = Split(Cells(i, 2).Value, ",")
For Each a In arr
Cells(j, 3).Value = v
Cells(j, 4).Value = a
j = j + 1
Next a
Next i
End Sub
The output is in cols C and D.
Since i find my problem hard to explain, I'll just provide an example.
This is the format of the data i have in excel in a column, separated by blanks.
A
B
C
D
E
F
G
H
I wish to transpose it so that the final result is:
A B F
C G
D H
E
How do I do that?
Here is Honorez's method:
Sub Honorez()
Dim N As Long, i As Long, j As Long, k As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
j = 2
k = 0
For i = 1 To N
v = Cells(i, 1)
If v = "" Then
j = j + 1
k = 0
Else
k = k + 1
Cells(k, j) = v
End If
Next i
End Sub
Array method
In addition to #Gary's-Student 's fine solution, I demonstrate another approach using a datafield Array and write back values directly to the new columns:
Sub Honorez2()
Dim rng As Range
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Honorez")
Dim i As Long, ii As Long, j As Long, m As Long, n As Long
Dim a()
' get data
n = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set rng = ws.Range("A1:A" & n)
rng.Offset(0, 1).Resize(n, n - WorksheetFunction.CountA(Range("A:A")) + 1) = "" ' clear prior values
' write data field to array
a = rng
j = 2 ' start column for results
For i = 1 To n
If a(i, 1) = "" Or i = n Then
' write data to new column
ws.Range(ws.Cells(1, j), ws.Cells(i - ii, j)).Value = _
ws.Range(ws.Cells(ii + 1, 1), ws.Cells(i, 1)).Value
' remember row and increment column counter
ii = i: j = j + 1
End If
Next i
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'm a Macro novice - just figured out how to add the developer tab, so sorry if my question is dumb. I have a list of items in Column A and quantity in Column B. I want to copy Columns A and B to Columns D and E, but only if the value in Column B > 0 - and I want them to stack, no blank spaces for the quantity = 0 ones. I found some code online:
Sub copyAboveZero()
Dim sourceRng As Range
Dim cell As Range
Dim i As Long
Set sourceRng = ActiveSheet.Range("B6:B24")
i = 6
For Each cell In sourceRng
If cell.Value > 0 Then
cell.Resize(1, 2).Copy Destination:=Range("D" & i)
i = i + 1
End If
Next cell
End Sub
The problem is that in this example, the quantity was in the first cell. This one is copying Columns B and C, and I want it to copy A and B. What do I need to change? Also, can you paste special values only? I don't want the formatting to come with it.
How about:
Sub KopyKat()
Dim N As Long, i As Long
Dim j As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
j = 1
For i = 1 To N
If Cells(i, "B").Value > 0 Then
Range(Cells(i, "A"), Cells(i, "B")).Copy Cells(j, "D")
j = j + 1
End If
Next i
End Sub
EDIT#1:
This addresses your comments:
Sub KopyKat()
Dim N As Long, i As Long
Dim J As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
J = 6
For i = 6 To N
If Cells(i, "B").Value > 0 And Cells(i, "B") <> "" Then
Range(Cells(i, "A"), Cells(i, "B")).Copy
Cells(J, "D").PasteSpecial (xlValues)
J = J + 1
End If
Next i
End Sub