I am stuck on problem where my vba won't increment row number. My tables looks like:
Sheet1
name value
aa 11
bb 12
cc 13
aa 14
cc 15
cc 16
aa 17
bb 18
aa 19
Sheet2
name
aa
bb
cc
I need to search for each specific value, if found copy adjacent cell to sheet2 right next searched value. This is code doing but problem is with row incrementation, all searched values are in one row (variable k is not working).
Sub finall()
Dim cable As String
Dim finalrow1 As Integer
Dim finalrow2 As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
l = 2
k = 2
finalrow2 = Sheets("Sheet2").Range("A1000").End(xlUp).Row
finalrow1 = Sheets("Sheet1").Range("A1000").End(xlUp).Row
For j = 2 To finalrow2
cable = Sheets("Sheet2").Cells(j, 1).Value
For i = 2 To finalrow1
If Cells(i, 1) = cable Then
Sheets("Sheet1").Cells(i, 2).Copy
Sheets("Sheet2").Cells(k, l).End(xlUp).Offset(1, 0).PasteSpecial
l = l + 1
End If
Next i
k = k + 1
Next j
End Sub
This is only example in final i want to apply this code to table with 50-60k rows.
Final table should look like:
name
aa 11 14 17 19
bb 12 18
cc 13 15 16
Thx
Final code would be as below
Sub finall()
Dim cable As String
Dim finalrow1 As Long
Dim finalrow2 As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
l = 2
k = 2
finalrow2 = Sheets("Sheet2").Range("A1000").End(xlUp).Row
finalrow1 = Sheets("Sheet1").Range("A1000").End(xlUp).Row
Worksheets("Sheet2").Select
For j = 2 To finalrow2
cable = Sheets("Sheet2").Cells(j, 1).Value
For i = 2 To finalrow1
If Sheets("Sheet1").Cells(i, 1) = cable Then
Sheets("Sheet1").Cells(i, 2).Copy
Sheets("Sheet2").Cells(k, l).PasteSpecial
l = l + 1
End If
Next i
k = k + 1
l = 2
Next j
End Sub
Proof of work
Related
Would appreciate any help here based on a previous question.
The code below was the original ask and finding a way in VBA to turn the original table into the output excel.
Data 4/1/2012 4/2/2012 4/3/2012 4/4/2012 4/5/2012
V 10 20 30 40 50
H 5 10 15 20 25
S 6 12 18 24 30
R 8 16 24 32 40
A 9 18 27 36 45
Output : Excel Table
V 4/1/2012 10
V 4/2/2012 20
V 4/3/2012 30
V 4/4/2012 40
V 4/5/2012 50
H 4/1/2012 5
H 4/2/2012 10
H 4/3/2012 15
H 4/4/2012 20
H 4/5/2012 25
.
.
.
A 4/1/2012 9
A 4/2/2012 18
A 4/3/2012 27
A 4/4/2012 36
A 4/5/2012 45
The answer is below and works, but I was hoping for some help in terms of adapting the code below so the output is created on a new sheet within the same workbook. What code should be added? Thank you.
Option Explicit
Sub colsToRows()
Dim ws1 As Worksheet
Dim a As Long, lr As Long, lc As Long
Dim va As Variant, vd As Variant
Dim LastRow As Long, LastCol As Long
'-- set e.g. sheet name Sheet1, starting column = B, dates starting cell = C2
Set ws1 = Sheets("Sheet1")
LastRow = ws1.Range("B" & ws1.Rows.Count).End(xlUp).Row
LastCol = ws1.Cells(Range("C2").Row, ws1.Columns.Count).End(xlToLeft).Column - 1
'--put dates into this array as it repeats for each item
vd = WorksheetFunction.Transpose(WorksheetFunction.Transpose(ws1.Range("C2").Resize(1, LastCol - 1)))
'-- titles
ws1.Range("B2").Offset(LastRow + 1) = "Item"
ws1.Range("C2").Offset(LastRow + 1) = "Dates"
ws1.Range("D2").Offset(LastRow + 1) = "Data"
'--2 is deducted as the main range is starting from B3. So B3-B1 = 2
For a = 1 To LastRow - 2
'--to get next last row
lr = Cells(Rows.Count, "B").End(xlUp).Row
'--items
va = Array(ws1.Range("B2").Offset(a).Value)
ws1.Range("B1").Offset(lr).Resize(LastCol - 1) = Application.Transpose(va)
'--dates
ws1.Range("C1").Offset(lr).Resize(UBound(vd)) = Application.Transpose(vd)
'--data
va = WorksheetFunction.Transpose(WorksheetFunction.Transpose(ws1.Range("C2").Offset(a).Resize(1, LastCol - 1)))
ws1.Range("D1").Offset(lr).Resize(UBound(va)) = Application.Transpose(va)
Next a
End Sub
This code will put the result on a new sheet.
Note, it assumes the data starts in A1 on Sheet1.
Option Explicit
Sub colsToRowsToNewSheet()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim arrData As Variant
Dim arrOut As Variant
Dim idxRow As Long
Dim idxCol As Long
Dim cnt As Long
'-- set e.g. sheet name Sheet1, starting column = B, dates starting cell = C2
Set ws1 = Sheets("Sheet1")
' Set ws1 = ActiveSheet
arrData = ws1.Range("A1").CurrentRegion
ReDim arrOut(1 To (UBound(arrData, 1) - 1) * (UBound(arrData, 2) - 1), 1 To 3)
For idxRow = LBound(arrData, 1) + 1 To UBound(arrData, 1)
For idxCol = LBound(arrData, 2) + 1 To UBound(arrData, 2)
cnt = cnt + 1
arrOut(cnt, 1) = arrData(idxRow, 1)
arrOut(cnt, 2) = arrData(1, idxCol)
arrOut(cnt, 3) = arrData(idxRow, idxCol)
Next idxCol
Next idxRow
Set wsNew = Sheets.Add
wsNew.Range("A1:C1").Value = Array("Data", "Date", "Item")
wsNew.Range("A2:C2").Resize(cnt).Value = arrOut
End Sub
I have a sorted list of names in a single column. I would like to transform the names to 3X8 tables before printing them (printing single column would use too much paper). This is Excel. I'll copy names one by one and paste to a blank sheet.
Using numbers as an example, the resulting order should look like this:
1 9 17
2 10 18
3 11 19
4 12 20
5 13 21
6 14 22
7 15 23
8 16 24
25 33 41
26 34 42
27 35 43
........
Possible to get a general answer (n x m table)?
Below is what I have got. It's close but not quite right.
last_row = ThisWorkbook.Sheets(1).Cells(20000,1).End(xlUp).Row
For i = 1 To last_row/24 +1 Step 1
For k = 1 To 3 Step 1
For j = 1 To members_per_column Step 1
ThisWorkbook.Sheets(1).Cells( i + j + (k - 1) * 8 + (i - 1) * 16 + 1, _
name_column).Copy
Worksheets(destination_page).Cells( i + j - 1, (k - 1) +1).PasteSpecial _
Paste:=xlPasteValues
Next j
Next k
Next i
You were already close. I wrapped the code into a function so you can easily re-use it on any matrix size:
Option Explicit
Public Sub TransformIntoBlocks(ByVal MatrixRows As Long, ByVal MatrixColumns As Long, ByVal SourceRange As Range, ByVal OutputStartRange As Range)
Dim BlockStartRow As Long
BlockStartRow = 1
Dim iRowSource As Long
iRowSource = 1
Dim AmountOfBlocks As Long
AmountOfBlocks = WorksheetFunction.RoundUp(SourceRange.Rows.Count / (MatrixRows * MatrixColumns), 0)
Dim iBlock As Long
For iBlock = 1 To AmountOfBlocks
Dim iCol As Long
For iCol = 1 To MatrixColumns
Dim iRow As Long
For iRow = BlockStartRow To BlockStartRow + MatrixRows - 1
OutputStartRange.Offset(iRow - 1, iCol - 1).Value = SourceRange(iRowSource, 1).Value
iRowSource = iRowSource + 1
Next iRow
Next iCol
BlockStartRow = BlockStartRow + MatrixRows
Next iBlock
End Sub
Sub test()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
TransformIntoBlocks MatrixRows:=8, MatrixColumns:=3, SourceRange:=ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp)), OutputStartRange:=Tabelle2.Range("C1")
End Sub
Rather than going through three loops, I ended up just using one loop to write in the correct position using mod.
Seems obvious to me as the writer, but please ask questions if it's unclear- it helps the next reader.
Option Explicit
Sub ColumnSplit()
Dim input_rows As Integer
Dim output_columns As Integer
Dim output_rows As Integer
Dim i As Integer
Dim input_sheet As Worksheet
Dim output_sheet As Worksheet
Set input_sheet = Sheet1
Set output_sheet = Sheet2
'output_sheet.Cells.Clear 'optional
output_columns = 3 'Hard coded. Set to whatever you like
input_rows = input_sheet.Cells(Rows.Count, 1).End(xlUp).Row
output_rows = CInt(WorksheetFunction.Ceiling(CDbl(input_rows) / CDbl(output_columns), 1))
For i = 1 To input_rows
output_sheet.Cells( _
((i - 1) Mod output_rows) + 1 _
, (WorksheetFunction.Floor((i - 1) / output_rows, 1) Mod output_columns) + 1 _
) _
= input_sheet.Cells(i, 1) 'cells(calculate output row,calculate output column) = input value
Next i
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
I'm trying to create a permutation list in excel for 6 numbers, each in their own columnA-F and each number is from 1-38. when i run the VBA i find that the permutations far exceed rows 1048576 available in excel, so therefore the VBA ends at that point. i want a VBA that when the rows reach 1048576 on whatever sheet and the permutation isnt finished it will just create a new sheet and continue where it stopped on the previous sheet and automatically create sheets until the permutation ends. i've searched passed questions but none found to help. Any expert help would be greatly appreciated.
Code:
Sub Perm()
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim d As Integer
Dim e As Integer
Dim f As Integer
n = 1
For a = 1 To 38
For b = 1 To 38
For c = 1 To 38
For d = 1 To 38
For e = 1 To 38
For f = 1 To 38
Cells(n, 1).Value = a
Cells(n, 2).Value = b
Cells(n, 3).Value = c
Cells(n, 4).Value = d
Cells(n, 5).Value = e
Cells(n, 6).Value = f
n = n + 1
Next f
Next e
Next d
Next c
Next b
Next a
End Sub
This should do it for you:
Sub Perm()
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim d As Integer
Dim e As Integer
Dim f As Integer
Dim n As Long
Dim maxRows As Long
Dim sheetNumber As Integer
Dim loopCounter As Integer
maxRows = 1048576
loopCounter = 38
sheetNumber = 1
n = 1
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Sheet-" & sheetNumber
Application.ScreenUpdating = False
For a = 1 To loopCounter
For b = 1 To loopCounter
For c = 1 To loopCounter
For d = 1 To loopCounter
For e = 1 To loopCounter
For f = 1 To loopCounter
Cells(n, 1).Value = a
Cells(n, 2).Value = b
Cells(n, 3).Value = c
Cells(n, 4).Value = d
Cells(n, 5).Value = e
Cells(n, 6).Value = f
If n = maxRows Then
sheetNumber = sheetNumber + 1
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Sheet-" & sheetNumber
n = 0
End If
n = n + 1
Next f
Next e
Next d
Next c
Next b
Next a
Application.ScreenUpdating = False
End Sub
This will create a sheet called "Sheet-1" and fill it up down to row 1048576.
Then it will create a new sheet called "Sheet-2" and repeat until that is full, etc.
It is best to disable ScreenUpdating for intensive cell writing as it will make a big reduction to the running time.
Good luck, as it will probably take awhile. As the other poster says, it will need nearly 3000 worksheets. Hopefully you have enough memory on your machine.
I'm working on a google spreadsheet with something like this (it's a single column):
1
2
3,4
5
6-9
15
18
3,4 is 3 and 4
6-9 is 6, 7, 8 and 9
On another sheet I made a standard 1-100 list and I have to find a way to "mark" the numbers that appears or that are included on the previous list, like this.
1 YES
2 YES
3 YES
4 YES
5 YES
6 YES
7 YES
8 YES
9 YES
10 NO
11 NO
12 NO
13 NO
14 NO
15 YES
I can easily find the simple unique numbers by using in cell B1:
=IF((COUNTIF(list!$A$1:$A$100,VALUE(A1))=1),"YES","NO")
I can even find what the first number is:
=IFERROR(LEFT(list!$A$1:$A$100,(SEARCH(",",list!$A$1:$A$100)-1)),IFERROR(LEFT(list!$A$1:$A$100,(SEARCH("-",list!$A$1:$A$100)-1)),list!$A$1:$A$100))
But I can't expand the search to include the numbers between the "x-y" or after the comma in "x,y".
I've tried AND("bigger than 1st number","smaller than 2nd number") but I haven't found a way to extract the second number.
Any suggestion?
Here is a macro that will work for an excel spreadsheet. You can adapt it to Google apps script:
Sub IsItThere()
Dim s1 As Worksheet, s2 As Worksheet, N As Long
Dim v As Variant, i As Long, ary()
Dim N1 As Long, N2 As Long, j As Long
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
s1.Activate
N = Cells(Rows.Count, "A").End(xlUp).Row
Dim c As Collection
Set c = New Collection
For i = 1 To N
v = Cells(i, 1).Value
If InStr(1, v, ",") > 0 Then
c.Add CLng(Split(v, ",")(0))
c.Add CLng(Split(v, ",")(1))
ElseIf InStr(1, v, "-") > 0 Then
N1 = CLng(Split(v, "-")(0))
N2 = CLng(Split(v, "-")(1))
For j = N1 To N2
c.Add j
Next j
Else
c.Add CLng(v)
End If
Next i
ReDim ary(1 To c.Count)
For i = 1 To c.Count
ary(i) = c.Item(i)
Next i
s2.Activate
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
v = Cells(i, 1).Value
For j = 1 To c.Count
If v = ary(j) Then
Cells(i, 2).Value = "YES"
GoTo pass
End If
Next j
Cells(i, 2).Value = "NO"
pass:
Next i
End Sub