I have a DATA sheet which contains data rows as follows:
And I have a sheet named ROWBUILDER that has formulas and produces results like this:
I would like to write a VBA code that will cycle through every row in the ROWBUILDER sheet and output data to a new worksheet.
NOTE: The ROWBUILDER sheet must remain as is. Only the resulting data must be copied to the OUTPUT sheet.
I have no idea how to do it and from where to start. Will appreciate any help, examples or links.
Many thanks in advance!
This moves all the data to one output sheet.
Sub MoveROWBUILDER()
Sheets("ROWBUILDER").Range("A1").CurrentRegion.Copy
Sheets("Output").Range("A1").PasteSpecial xlPasteValues
End Sub
If you are looking for one sheet per row, try this. You may run into a limit depending on memory and the amount of data.
Sub DataToSheets()
Dim sh As Worksheet
Dim rowCount As Integer, colCount As Integer
Dim i As Integer, j As Integer
Dim data() As Variant
Sheets("ROWBUILDER").Select
rowCount = Range("A1").CurrentRegion.Rows.Count
colCount = Range("A1").CurrentRegion.Columns.Count
data() = Sheets("ROWBUILDER").Range("A1").CurrentRegion.Value2
For i = 2 To rowCount
Set sh = Sheets.Add(After:=ActiveSheet)
sh.Name = "Data" & (i - 1)
For j = 1 To colCount
sh.Cells(1, j) = data(1, j)
sh.Cells(2, j) = data(i, j)
Next j
Next i
End Sub
If you can estimate the maximum number of rows in your data sheet then - instead of cycling through every row - you can use
rowbuilder.Range("A1:B" & lastrow).Copy
newworksheet.Range("A1").PasteSpecial xlValues
Let me try this again now that I have a better idea of what you need.
You can process all of the rows at once using dynamics arrays in ROWBUILDER. Set C1 in ROWBUILDER to
=COUNTA(DATA!A:A) - 1
Then set A2 to
=OFFSET(DATA!A2,0,0,C1,1) & " " & OFFSET(DATA!B2,0,0,C1,1)
This will spill all of the full names to column A. You can then set B2 to
=OFFSET(DATA!H2,0,0,C1,1) & " " & OFFSET(DATA!G2,0,0,C1,1) & " " & OFFSET(DATA!F2,0,0,C1,1) & OFFSET(DATA!E2,0,0,C1,1)
This will spill the Full Address to Column B. IF you still need to copy it to OUTPUT, then this code should do the job.
Range("A2#").Copy
offsetrows = Sheets("OUTPUT").Range("A1").CurrentRegion.Rows.Count
Sheets("OUTPUT").Select
Range("A1").Offset(offsetrows, 0).Select
Selection.PasteSpecial xlPasteValues
You can use loop like this:
numberRows = Range("A2").End(xlToDown).Row
Sheets.Add.Name = "OUTPUT"
For i = 2 To numberRows
Sheets("OUTPUT").Cells(i, 1).Value = Sheets("DATA").Cells(i, 1).Value
Sheets("OUTPUT").Cells(i, 2).Value = Sheets("DATA").Cells(i, 8).Value & " " & Sheets("DATA").Cells(i, 7).Value & " " & Sheets("DATA").Cells(i, 6).Value & " " & Sheets("DATA").Cells(i, 5).Value
Next i
Related
I have an excel with 2 columns,say 10 values each as given in the below diagram. The 10 values in A and B are added in a drop down in column E and column F. I want the column D, "Result", to show me 100 different possible permutations of the values again in a drop down. I tried to write a macro but getting lost somewhere. EDIT: Added the error that i am getting. any help is greatly appreciated. Example of what is expected (remember column E and F are dropdowns)
Below is the macro i have tried:
Sub Combination()
Dim arr1 As Variant
Dim arr2 As Variant
Dim i As Long, j As Long, k As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
arr1 = ws.Range("E1", ws.Range("E" & ws.Rows.Count).End(xlUp).Row).Value
arr2 = ws.Range("F1", ws.Range("F" & ws.Rows.Count).End(xlUp).Row).Value
ws.Range("D1").Value = "Result"
k = 1
For i = LBound(arr1, 1) To UBound(arr1, 1)
For j = LBound(arr2, 1) To UBound(arr2, 1)
ws.Range("D" & k + 1).Value = arr1(i, 1) & ", " & arr2(j, 1)
k = k + 1
If k = 101 Then Exit For
Next j
If k = 101 Then Exit For
Next i
End Sub
Debugger shows an error in this line of code:
arr1 = ws.Range("E1", ws.Range("E" & ws.Rows.Count).End(xlUp).Row).Value
How else am i supposed to read the values in the drop down?
This task doesn't necessarily require a VBA solution: it is achievable using dynamic spreadsheet functions (if you have a relatively recent version of Excel). To my mind, people reach for VBA too readily, when it would be better to exhaust the possibilities of spreadsheet functions first.
1. Calculate the permutations
Put this formula in cell H2:
=LET(a,A2:A11,b,B2:B10,na,ROWS(a),nb,ROWS(b),s,SEQUENCE(na*nb,,0),INDEX(a,1+(INT(s/nb))) & "," & INDEX(b,1+MOD(s,nb)))
2. Set the Data Validation:
Note the # on the end of the $D$2# reference for Source. This tells Excel that the reference is to a dynamic array.
If you don't want the intermediate column displayed, then it can be Hidden or even put on another tab. Currently Excel only allows relatively simple formulae for Data Validation ranges, otherwise this column would not be needed.
Display the selections for Options A & B:
Cell E2 has the formula =LEFT(D2,FIND(",",D2)-1)
Cell F2 has the formula =RIGHT(D2,LEN(D2)-LEN(E2)-1)
You can use MATCH() to recover the index of the option in input list if required, eg =MATCH(E2,A2:A11,0) if that is needed.
Notes:
Using spreadsheet formulae rather than VBA has three benefits:
The sheet can still be saved and shared as a .xlsx file and not
.xlsm, so reducing the number of security warnings;
It is easier to see the results and test;
The sheet will update automatically (if calculation is set to Automatic), whereas a VBA macro would have to be re-run.
EDIT: An alternative, slightly more complicated formula for H2 could be:
=LET(optA,A2,optB,B2,colA,A:A,colB,B:B,
rngA,INDEX(colA,ROW(optA),,1):INDEX(colA,COUNTA(colA),ROW(optA)-1),
rngB,INDEX(colB,ROW(optB),,1):INDEX(colB,COUNTA(colB),ROW(optB)-1),
na,ROWS(rngA),nb,ROWS(rngB),s,SEQUENCE(na*nb,,0),
INDEX(rngA,1+(INT(s/nb))) & "," & INDEX(rngB,1+MOD(s,nb)))
This would handle changes to size of the Option A and Option B columns. An even more adaptive formula could use INDIRECT(), but I am against that on principle!
Answering my own question:
Wrote Macro 1:
Sub Combination1()
Dim arr1 As Variant
Dim arr2 As Variant
Dim i As Long, j As Long, k As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
arr1 = ws.Range("E1", ws.Range("E" & ws.Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Value
arr2 = ws.Range("F1", ws.Range("F" & ws.Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Value
ws.Range("D1").Value = "Result"
k = 1
For i = LBound(arr1, 1) To UBound(arr1, 1)
For j = LBound(arr2, 1) To UBound(arr2, 1)
ws.Range("D" & k + 1).Value = arr1(i, 1) & ", " & arr2(j, 1)
k = k + 1
If k = 101 Then Exit For
Next j
If k = 101 Then Exit For
Next i
' Add data validation to column D
With ws.Range("D2", ws.Range("D" & k).End(xlUp))
.Validation.Delete
.Validation.Add Type:=xlValidateList, Formula1:="=" & ws.Range("D2:D" & k).Address
End With
End Sub
This basically reads the values from drop downs.
Macro 2:
Sub Combination2()
Dim arr3 As Variant
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
arr3 = ws.Range("D2", ws.Range("D" & ws.Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Value
ws.Range("G1").Value = "Result"
For i = LBound(arr3, 1) To UBound(arr3, 1)
ws.Range("G" & i + 1).Value = arr3(i, 1)
Next i
' Add data validation to column G
With ws.Range("G2")
.Validation.Delete
.Validation.Add Type:=xlValidateList, Formula1:="=" & ws.Range("D2:D" & UBound(arr3, 1) + 1).Address
End With
' Clear values in column G except for cell G2
ws.Range("G3", ws.Range("G" & ws.Rows.Count).End(xlUp)).ClearContents
End Sub
This helps to populate the values in another dropdown
Macro 3:
Sub CombinedMacros()
Call Combination1
Call Combination2
End Sub
Happy to "help" people if they have any doubts.
I'm writing a macro to concatenate a few columns into another column for a sheet that will eventually have thousands of rows. For the sake of testing I'm using four rows of data. My issue is that the Cells(i,25).Value is not populating when I run the following code. The code isn't breaking and I'm not getting any error messages. I tried assigning a 2 to column 26 using Cells(i,26) and that wasn't working either.
Sub concat()
Dim i As Long
Dim add As String
i = 1
Do Until IsEmpty(Cells(i, 1))
add = Cells(i, 14).Value
Cells(i, 25).Value = Cells(i, 1).Value & " " & Cells(i, 2).Value & " " & Left(add, 3)
i = i + 1
Loop
End Sub
Any help or recommendations would be greatly appreciated!
I recommend you change the code a little. I have used the IsEmpty command before and it's not the most suitable one for this.
Sub concat()
Dim i As Long
Dim add As String
Dim last_1 As Long
Dim last_2 As Long
Dim last_14 As Long
Dim lastCell As Long
last_1 = Sheets("test3").Cells(Rows.Count, 1).End(xlUp).Row
last_2 = Sheets("test3").Cells(Rows.Count, 2).End(xlUp).Row
last_14 = Sheets("test3").Cells(Rows.Count, 14).End(xlUp).Row
lastCell = WorksheetFunction.Max(last_1 , last_2, last_14)
For i = 1 To lastCell
add = Sheets("test3").Cells(i, 14).Value
Sheets("test3").Cells(i, 25).Value = Sheets("test3").Cells(i, 1).Value & " " & Sheets("test3").Cells(i, 2).Value & " " & Left(add, 3)
Next i
End Sub
Variance Table Sample I'm working on an Excel Macros (VBA) to look through every 3rd cell of each row in a data set and perform a copy paste action based on conditions (Please see the code at the bottom).
The source data is in a another worksheet (Variance). It has 1300+ IDs (rows) and 3 columns for each value component (col 1 - value 1, col 2 - value 2, and col 3 - the difference between the 2 values) and likewise there are 500+ columns.
My code basically looks through every third column (the difference column) of each row to find out if the value is a number, not equal to zero, and if it's not an error (there are errors in the source sheet). If yes, it copies the Emp ID, the column Name, and both the values into another worksheet called vertical analysis (one below the other).
The code works fine, but it takes 6 to 7 minutes for a data set with 1000+ rows and 500+ columns.
Can someone please tell me if there is a faster way to do this than to loop through each row?
Please let me know if you need more information. Thanks in advance.
Code:
Sub VerticalAnalysis()
Dim EmpID As Range
Dim i As Long
Dim cell As Range
Dim lastrow As Range
Dim LastCol As Long
Dim curRow As Long
Dim c As Long
Set lastrow = ThisWorkbook.Worksheets("Variance").Cells(Rows.Count, 2).End(xlUp)
Set EmpID = ThisWorkbook.Worksheets("Variance").Range("B4", lastrow)
LastCol = ThisWorkbook.Worksheets("Variance").Cells(3, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
MsgBox "Depending on the size of the record, your excel will not respond for several minutes during Vertical Analysis. Please don't close the workbook", , "Note: Please Don't Close the Workbook"
Worksheets("Vertical").Select
Range("B3", "H" & Rows.Count).ClearContents
Range("B3", "H" & Rows.Count).ClearFormats
ThisWorkbook.Worksheets("Variance").Select
c = 1
For Each cell In EmpID
i = 2
Do Until i >= LastCol
cell.Offset(0, i).Select
If IsError(ActiveCell) Then
ElseIf ActiveCell <> "" Then
If IsNumeric(ActiveCell) = True Then
If ActiveCell <> 0 Then
cell.Copy
Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(-c, -2).Copy
Worksheets("Vertical").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -2).Copy
Worksheets("Vertical").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -1).Copy
Worksheets("Vertical").Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End If
End If
i = i + 4
Loop
c = c + 1
Next cell
ThisWorkbook.Worksheets("Vertical").Select
Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Row - 2 & " Components have variations", , "Success!"
Application.ScreenUpdating = True
End Sub
You might try to use SQL. In order to learn how to use sql in EXCEL VBA, I suggest you to follow this tuto and to apply your learn on your macro. They will be faster =)
https://analystcave.com/excel-using-sql-in-vba-on-excel-data/
Better not to hit the sheet so many times.
Below is tested and should run in a few seconds, but you may need to tweak the column positions etc:
Sub VerticalAnalysis()
Const BLOCK_SIZE As Long = 30000
Dim lastrow As Long
Dim LastCol As Long
Dim c As Long, wsVar As Worksheet, wsVert As Worksheet, n As Long
Dim data, r As Long, empId, v, rwVert As Long, dataVert, i As Long
Set wsVar = ThisWorkbook.Worksheets("Variance")
Set wsVert = ThisWorkbook.Worksheets("Vertical")
lastrow = wsVar.Cells(Rows.Count, 2).End(xlUp).Row
LastCol = wsVar.Cells(3, Columns.Count).End(xlToLeft).Column
'get all the input data as an array (including headers)
data = wsVar.Range("A3", wsVar.Cells(lastrow, LastCol)).Value
'clear the output sheet and set up the "transfer" array
With wsVert.Range("B3", "H" & Rows.Count)
.ClearContents
.ClearFormats
End With
rwVert = 3 'first "vertical" result row
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4) 'for collecting matches
i = 0
n = 0
For r = 2 To UBound(data, 1) 'loop rows of input array
empId = data(r, 2) 'colB ?
c = 7 'first "difference" column ?
Do While c <= UBound(data, 2)
v = data(r, c)
If Not IsError(v) Then
If IsNumeric(v) Then
If v > 0.7 Then
i = i + 1
n = n + 1
dataVert(i, 1) = empId
dataVert(i, 2) = data(1, c) 'header
dataVert(i, 3) = data(r, c + 2) 'value1
dataVert(i, 4) = data(r, c + 1) 'value2
'have we filled the temporary "transfer" array?
If i = BLOCK_SIZE Then
wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
i = 0
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4)
rwVert = rwVert + BLOCK_SIZE
End If
End If
End If
End If
c = c + 4 'next difference
Loop
Next r
'add any remaining
If i > 0 Then wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
wsVert.Select
wsVert.Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & n & " Components have variations", , "Success!"
End Sub
so i have Sheet1 that is use to contain the list of my inventory data. what i want to do is in another sheet(Sheet2). i can search my Sheet1 data and display the data there ( for example when i type cheetos, only the cheetos item got display ). Help me guys, using VBA is okay or other method is also fine.
If your results don't have to be on a different sheet, you could just convert your data to a Table. Select Cells A1:D8 and click on Insert -> Table. Make sure "My table has headers" is clicked and voila!
Once formatted as a table, you can filter Product ID however you need.
If you do need to show these results in another sheet, VBA would be my go-to solution. Maybe something like this:
Public Sub FilterResults()
Dim findText As String
Dim lastRow As Long
Dim foundRow As Long
Dim i As Long
'If there's nothing to search for, then just stop the sub
findText = LCase(Worksheets("Sheet2").Range("D4"))
If findText = "" Then Exit Sub
'Clear any old search results
lastRow = Worksheets("Sheet2").Cells(Rows.Count, 4).End(xlUp).Row
If lastRow > 5 Then
For i = 6 To lastRow
Worksheets("Sheet2").Range("C" & i).ClearContents
Worksheets("Sheet2").Range("D" & i).ClearContents
Worksheets("Sheet2").Range("E" & i).ClearContents
Worksheets("Sheet2").Range("F" & i).ClearContents
Next i
End If
'Start looking for new results
lastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
foundRow = 6
For i = 2 To lastRow
If InStr(1, LCase(Worksheets("Sheet1").Range("B" & i)), findText) <> 0 Then
Worksheets("Sheet2").Range("C" & foundRow) = Worksheets("Sheet1").Range("A" & i)
Worksheets("Sheet2").Range("D" & foundRow) = Worksheets("Sheet1").Range("B" & i)
Worksheets("Sheet2").Range("E" & foundRow) = Worksheets("Sheet1").Range("C" & i)
Worksheets("Sheet2").Range("F" & foundRow) = Worksheets("Sheet1").Range("D" & i)
foundRow = foundRow + 1
End If
Next i
'If no results were found, then open a pop-up that notifies the user
If foundRow = 6 Then MsgBox "No Results Found", vbCritical + vbOKOnly
End Sub
I would recommend avoiding VBA for this process as it can be done easily with excel's functions. If you would like to do it via VBA one could just loop through the list of products and find a key word, adding it to an array if the "Cheetos" is contained in the specific cell value using a wildcard like so:
This could be modified to run upon the change of the D4 cell if needed, and of course some modifications could be done to ensure that formatting etc can be done to your liking.
Sub test()
Dim wb As Workbook
Dim rng As Range, cell As Range
Dim s_key As String, s_find() As String
Dim i As Long
Set wb = Application.ThisWorkbook
Set rng = wb.Sheets("Sheet1").Range("B2:B8")
s_key = wb.Sheets("Sheet2").Range("D4").Value
wb.sheets("Sheet2").Range("C6:F9999").clearcontents
i = 0
For Each cell In rng
If cell.Value Like "*" & s_key & "*" Then
ReDim Preserve s_find(3, i)
s_find(0, i) = cell.Offset(0, -1).Value
s_find(1, i) = cell.Value
s_find(2, i) = cell.Offset(0, 1).Value
s_find(3, i) = cell.Offset(0, 2).Value
i = i + 1
End If
Next cell
wb.Sheets("Sheet2").Range("C6:F" & 5 + i).Value = Application.WorksheetFunction.Transpose(s_find)
End Sub
I am new to macros in excel and I am trying to create one that will help me to copy data from cells from one sheet to another based on matching. Basically I want excel to look into Column H from Sheet1 and if data from any cell will match data from any cell in Column E from Sheet2, it will copy a column range from Sheet1 to Sheet2 to the relevant row (where the matching was found).
For example:
If data from H5 (sheet1) matches data from E1 (sheet2) than cells I5 to J5 (sheet1) should be copied to cells F1 to G1.
Currently I have this macro which is doing part of the job:
Sub asd()
For Counter = 1 To 10
If Sheets(1).Range("H" & Counter).Value = Sheets(2).Range("E" & Counter).Value Then
Sheets(2).Range("F" & (Counter)).Value = Sheets(1).Range("I" & Counter).Value
Sheets(2).Range("G" & (Counter)).Value = Sheets(1).Range("J" & Counter).Value
End If
Next Counter
End Sub
The problem with it is that as soon as there is no match between column H (sheet1) to column E (Sheet2) the macro stops. I am sure there is a simple way to make it jump to the next row if there is no match until all rows are done.
Can anyone edit this code to make it work?
Working under the assumption that you want your code to run for more than the first 10 lines of the two sheets, give this a try:
Sub asd()
'this runs through all used rows in sheet 1
For Counter = 1 To Sheets(1).UsedRange.Rows.Count
'this ensures that cell H<row> has a non-blank value
'you can leave this If statement out if you know there will be no blanks in Column H
If sheets(1).Range("H" & counter) <> "" then
If Sheets(1).Range("H" & Counter).Value = Sheets(2).Range("E" & Counter).Value Then
Sheets(2).Range("F" & (Counter)).Value = Sheets(1).Range("I" & Counter).Value
Sheets(2).Range("G" & (Counter)).Value = Sheets(1).Range("J" & Counter).Value
End If
End if
Next Counter
End Sub
You need 2 loops to compare the value from Sheet1 with all others in Sheet2 :
Sub asd()
Dim lngLastRowSht1 As Long
Dim lngLastRowSht2 As Long
Dim counterSht1 As Long
Dim counterSht2 As Long
With Worksheets(1)
lngLastRowSht1 = .Cells(.Rows.Count, 8).End(xlUp).Row
lngLastRowSht2 = Worksheets(2).Cells(Worksheets(2).Rows.Count, 5).End(xlUp).Row
For counterSht1 = 1 To lngLastRowSht1
For counterSht2 = 1 To lngLastRowSht2
If .Cells(counterSht1, 8) = Worksheets(2).Cells(counterSht2, 5) Then
Worksheets(2).Cells(counterSht2, 6) = .Cells(counterSht1, 9)
Worksheets(2).Cells(counterSht2, 7) = .Cells(counterSht1, 10)
End If
Next counterSht2
Next counterSht1
End With
End Sub
Great guys!
Both codes are working perfectly.
There is one more thing I would need to add to it.
How can I define a range of column that need to be copied?
For e.g. instead of having this lines twice:
Sheets(2).Range("F" & (Counter)).Value = Sheets(1).Range("I" & Counter).Value
Sheets(2).Range("G" & (Counter)).Value = Sheets(1).Range("J" & Counter).Value
Or this twice
Worksheets(2).Cells(counterSht2, 6) = .Cells(counterSht1, 9)
Worksheets(2).Cells(counterSht2, 7) = .Cells(counterSht1, 10)
How can I define "I want all columns between I and AL (sheet 1) to be copied to all columns between F to AI (sheet 2)"? I have to work with 500 columns and will take a lot of time to do one line for each.
Thanks a lot!
Mihai
I have combined the two suggestions offered by FreeMan and Branislav Kollár and come up with a code that is working to also select a larger range to be copied. If anyone wants this in the future, please see below the code I got:
Sub CopyCells()
Dim lngLastRowSht1 As Long
Dim lngLastRowSht2 As Long
Dim counterSht1 As Long
Dim counterSht2 As Long
With Worksheets(1)
lngLastRowSht1 = .Cells(.Rows.Count, 8).End(xlUp).Row
lngLastRowSht2 = Worksheets(2).Cells(Worksheets(2).Rows.Count, 5).End(xlUp).Row
For counterSht1 = 1 To lngLastRowSht1
For counterSht2 = 1 To lngLastRowSht2
If Sheets(1).Range("H" & (counterSht1)).Value = Sheets(2).Range("E" & counterSht2).Value Then
Sheets(2).Range("F" & (counterSht2), "H" & (counterSht2)).Value = Sheets(1).Range("I" & counterSht1, "K" & counterSht1).Value
End If
Next counterSht2
Next counterSht1
End With
End Sub
Thanks!
Mihai