Optimize VBA Script to Combine and Consolidate - excel

I am working on optimizing this script since I am working with two large (~1M rows) worksheets, each and think my code is inefficient and takes way too long to run and wondering if I can redo it to make it faster.
These are the steps:
Combine Excel Sheet 1 and Sheet 2 using Column A as common identifier
Add a column to identify if Columns E = H (True or False)
Remove all True's (this should get rid of most rows, leaving a few hundred)
Also, what does this line exactly mean? in particular the Columns (1), A, :M and G - want to confirm its picking the right matches
iRow = Application.Match(ID, ws2.UsedRange.Columns(1), 0)
If Not IsError(iRow) Then ws2.Range("A" & iRow & ":M" & iRow).Copy ws3.Range("G" & r.Row)
Sheet 1:
Sheet 2:
Final Expected Result:
Sub TestGridUpdate()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim TestGridFound As Boolean, r As Range
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
TestGridFound = False 'Look for TestGrid worksheet
For Each ws In Worksheets
If ws.Name = "Combined" Then TestGridFound = True
Next
If TestGridFound Then 'If Combined is found then use it else create it
Set ws3 = ThisWorkbook.Worksheets("Combined")
ws3.Cells.Clear
Else
Set ws3 = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
ws3.Name = "Combined"
End If
ws3.Range(ws1.UsedRange.Address).Value = ws1.UsedRange.Value 'Copy ws1 to ws3 (TestGrid)
For Each r In ws3.UsedRange.Rows ' Add ws2 details to ws3 (TestGrid)
ID = r.Cells(, 1).Value
iRow = Application.Match(ID, ws2.UsedRange.Columns(1), 0)
If Not IsError(iRow) Then ws2.Range("A" & iRow & ":M" & iRow).Copy ws3.Range("G" & r.Row)
Next
End Sub
Sub FillFormula() 'Add a column to identify column matches
'Set reference to the sheet in the workbook.
Set ws = ThisWorkbook.Worksheets("Combined")
ws.Activate 'not required but allows user to view sheet if warning message appears
Range("N2").Formula = "=$E2=H2"
Range("N2", "N" & Cells(Rows.Count, 1).End(xlUp).Row).FillDown
End Sub
Sub Delete_Rows_Based_On_Value() 'Delete all matches that are true'
'Apply a filter to a Range and delete visible rows
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Combined") 'Set reference to sheet in workbook.
ws.Activate 'not required but allows user to view sheet if warning message appears
On Error Resume Next 'Clear any existing filters
ws.ShowAllData
On Error GoTo 0
ws.Range("A:P").AutoFilter Field:=14, Criteria1:="TRUE" '1. Apply Filter
Application.DisplayAlerts = False '2. Delete Rows
Sheets("Combined").AutoFilter.Range.Offset(1).Delete xlShiftUp
Application.DisplayAlerts = True
On Error Resume Next '3. Clear Filter
ws.ShowAllData
On Error GoTo 0
End Sub

answer to your question,
the part:
For Each r In ws3.UsedRange.Rows ' Add ws2 details to ws3 (TestGrid)
ID = r.Cells(, 1).Value
iRow = Application.Match(ID, ws2.UsedRange.Columns(1), 0)
If Not IsError(iRow) Then ws2.Range("A" & iRow & ":M" & iRow).Copy ws3.Range("G" & r.Row)
Next
in a short way: it compares ws2 and w3 Column 1 - Column "A" values, if match is found, cell value from ws2 is copied to ws3.
Application.Match(ID, ws2.UsedRange.Columns(1), 0) will cause error if cell values do not match, accordingly, that's why the following line looks as below:
If Not IsError(iRow) Then ws2.Range("A" & iRow & ":M" & iRow).Copy ws3.Range("G" & r.Row) (perform with copying if no error).
To be honest, I suspect this code runs above a minute or even two if you deal with around 1mil rows.
Read and learn how to use arrays and how to assign ranges to arrays and how loop through them. Code will run MUCH faster as it will not be iterating through each actual cell on the excel, - all will be done in RAM memory (like in the virtual data table). No read/write (copy/paste) will be performed during the Array loop and at the end result will be written out in one step.
Quick tip, while creating large arrays, use .value2 it will also improve performance. my_Arr1 = range("my_range").Value2
Once you will understand simple arrays, get your brains to wrap around 2d arrays, as all ranges loaded to an array will end up 2d.
Examples to start from:
http://www.cpearson.com/excel/vbaarrays.htm
https://stackoverflow.com/a/23701283/8805842
How to avoid using Select in Excel VBA
https://stackoverflow.com/a/46954174/8805842
https://stackoverflow.com/a/30067221/8805842
For later read:
https://stackoverflow.com/a/51524230/8805842
https://stackoverflow.com/a/51608764/8805842

Related

Sum Values in different worksheets (same cell)

I have a workbook with multiple sheets ,the number of sheets can change for each project but they all end with PAF. The table is the same across all sheets as well as the cells.
I have a summary tab with the exact same table, I just need to sum it all up there, the table has at least 6 columns and 20 rows so each cell would need the same formula (basically) so I came up with the following but I'm getting an error. Any suggestions?
Sub SumPAF
Dim ws as Worksheet
Sheets("Summary PAF").Activate
For Each ws In ActiveWorkbook.Worksheets
If ws.Name Like "PAF" Then
Range("E10") = WorksheetFunction.Sum(Range("E10"))
End If
Next
End Sub
It's getting stuck in "For Each" saying that an Object is required...
I have commented the code so you should not have a problem understanding it.
Option Explicit
Sub SumPAF()
Dim ws As Worksheet
'~~> This will store the cell addresses
Dim sumFormula As String
'~~> Loop though each worksheet and check if it ends with PAF
'~~> and also to ingore summary worksheet
For Each ws In ActiveWorkbook.Worksheets
If UCase(ws.Name) Like "*PAF" And _
InStr(1, ws.Name, "Summary", vbTextCompare) = 0 Then _
sumFormula = sumFormula & "," & "'" & ws.Name & "'!E10"
'~~> or simply
'sumFormula = sumFormula & ",'" & ws.Name & "'!E10"
Next
'~~> Remove the intital ","
sumFormula = Mid(sumFormula, 2)
'~~> Insert the sum formula
If sumFormula <> "" Then _
Sheets("Summary PAF").Range("E10").Formula = "=SUM(" & sumFormula & ")"
End Sub
Here's a very simple and easy to understand program to illustrate how VBA can be used for loops over ranges. If you have any questions, feel free to ask:
Sub SumPAF()
'Save a reference to the Summary Sheet
Dim SummarySheet As Worksheet
Set SummarySheet = Sheets("Summary PAF")
'Save a reference to the Summary Table and decide the table dimensions
Dim SummaryTable As Range
Set SummaryTable = SummarySheet.Range("A1:F20")
'Create an array to save the sum values
Dim SumValues() As Double
ReDim SumValues(1 To SummaryTable.Rows.Count, 1 To SummaryTable.Columns.Count)
'Loop through the workbook sheets
Dim ws As Worksheet, TableRange As Range
For Each ws In ActiveWorkbook.Worksheets
'Find sheets ending in PAF other than the summary PAF
If ws.Name Like "*PAF" And Not ws.Name = SummarySheet.Name Then
'create a reference to a range on the sheet in the same place and dimensions as the summary table
Set TableRange = ws.Range(SummaryTable.Address)
'loop through the range, cell by cell
Dim i As Long, j As Long
For i = 1 To TableRange.Rows.Count
For j = 1 To TableRange.Columns.Count
'Sum each cell value into the array, where its cell address is the array coordinates.
SumValues(i, j) = SumValues(i, j) + TableRange.Cells(i, j).Value
Next j
Next i
End If
Next
'Output the array into the summary table
SummaryTable.Value = SumValues
End Sub

How to match columns and count the matches using vba

I am working on one scenario where I have two sheets. Sheet1 is the master sheet and sheet2 which I am creating.
Column1 of Sheet1 is Object which has duplicate objects as well. So, what I have done is I have created a macro which will produce the unique Objects and will paste it in sheet2.
Now, from Sheet2, each of the objects should be matched with Sheet1 column1 and based on the matching results, it should also count the corresponding entries from other columns in sheet1 to sheet2.
Below are the snapshots of my two sheets
Sheet1
Sheet2
here is my macro code which will first copy and paste the unique objects from sheet1 to sheet2 Column1.
Sub UniqueObj()
Dim Sh1 As Worksheet
Dim Rng As Range
Dim Sh2 As Worksheet
Set Sh1 = Worksheets("Sheet1")
Set Rng = Sh1.Range("A1:A" & Sh1.Range("A65536").End(xlUp).Row)
Set Sh2 = Worksheets("Sheet1")
Rng.Cells(1, 1).Copy Sh2.Cells(1, 1)
Rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sh2.Range("A1"), Unique:=True
End Sub
But, I am unable to move forward from there. I am pretty new and any help would be very greatful.
Thanks
If I'm understanding what you want correctly, you're just counting matching columns from Sheet1 where the value in the corresponding column isn't blank? If so this should do the trick.
Option Explicit
Sub GetStuffFromSheet1()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow1 As Long, lastRow2 As Long
Dim x As Long
'turn on error handling
On Error GoTo error_handler
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
'determine last row with data in sheet 1
lastRow1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
'determine last row with data in sheet 2
lastRow2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
'define columns in sheet 1
Const objCol1 As Long = 1
Const rProdCol1 As Long = 3
Const keysCol1 As Long = 4
Const addKeysCol1 As Long = 5
'define columns in sheet 2
Const objCol2 As Long = 1
Const rProdCol2 As Long = 2
Const keysCol2 As Long = 3
Const addKeysCol2 As Long = 4
'turn off screen updating + calculation for speed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'loop through all rows of sheet 2
For x = 2 To lastRow2
'formula counts # of cells with matching obj where value isn't blank
ws2.Cells(x, rProdCol2) = WorksheetFunction.CountIfs(ws1.Columns(objCol1), ws2.Cells(x, objCol2), ws1.Columns(rProdCol1), "<>" & "")
ws2.Cells(x, keysCol2) = WorksheetFunction.CountIfs(ws1.Columns(objCol1), ws2.Cells(x, objCol2), ws1.Columns(keysCol1), "<>" & "")
ws2.Cells(x, addKeysCol2) = WorksheetFunction.CountIfs(ws1.Columns(objCol1), ws2.Cells(x, objCol2), ws1.Columns(addKeysCol1), "<>" & "")
Next x
'turn screen updating + calculation back on
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
error_handler:
'display error message
MsgBox "Error # " & Err.Number & " - " & Err.Description, vbCritical, "Error"
'turn screen updating + calculation back on
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
End Sub
In case a non VBA solution works for you, you can resume your data with a Pivot Table, take field Object into rows section and rest of fields into values section (choose Count)
This returns the exact output you are looking for. Easy to update and easy to create.
In case you want a VBA solution, because your design is tabular and you are counting values, you can use CONSOLIDATE:
Consolidate data in multiple worksheets
'change K1 with cell where to paste data.
Range("K1").Consolidate Range("A1").CurrentRegion.Address(True, True, xlR1C1, True), xlCount, True, True, False
'we delete column relation type and column value. This columns depends on where you paste data, in this case, K1
Range("L:L,P:P").Delete Shift:=xlToLeft
After executing code i get this:
Hope this helps

Compare values in column B of sheet 1 to column B of sheet 2; append unmatched values in sheet 2

I'm trying to help a colleague with an excel report. He is not very good with computers and is making errors in copying all the relevant data from one sheet to another. He's working with a dataset that looks like this:
] [1]: https://i.stack.imgur.com/dHUpt.png (not allowed to upload images directly yet because i created a new account)
These are pending shipping values and everyday a report is generated with all the orders and the pending ones need to be copied into another sheet and then their status is updated in that excel sheet.
What I need is a solution that when I paste my report into sheet one, I can run a VBA code and compare all the values in column B of sheet one to all the values in column B of sheet two. Then, whatever is not present in column B of sheet two can be highlighted in sheet one or pasted into sheet three/ appended into sheet two. In this way, they operator does not have to do the lookup by himself.
If there is any other solution than VBA that could help, feel free to suggest. Thanks!
You can try this:
Sub CompareData()
Application.ScreenUpdating = False
On Error GoTo 0
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = wb.Worksheets("Sheet1") 'Change Sheet Name
Set ws2 = wb.Worksheets("Sheet2") 'Change Sheet Name
ws1.Copy after:=ws2
Set ws3 = wb.ActiveSheet
Dim LastRow1 As Long
Dim Rng As Range
With ws3
LastRow1 = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("E1").Value = "Vlookup"
.Range("E2").Value = "=VLOOKUP(B2," & ws2.Name & "!B:B,1,0)"
.Range("E2").Copy .Range("E3:E" & LastRow1)
.Range("A1:E1").AutoFilter FIELD:=5, Criteria1:="#N/A"
Set Rng = .AutoFilter.Range.Offset(1, 0)
Set Rng = Rng.Resize(Rng.Rows.Count, 4)
End With
Dim LastRow2 As Long
LastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
Rng.Copy ws2.Range("A" & LastRow2 + 1 & ":D" & LastRow2 + 1)
Application.DisplayAlerts = False
ws3.Delete
Application.DisplayAlerts = True
ws2.Activate
Exit Sub
0:
MsgBox "Something went wrong"
Application.ScreenUpdating = True
End Sub
Don't forget to change your sheet name.
For such tasks (comparing data in different worksheets), I usually use Excel built-in IF funcion. Example: =IF([Workbook_1]Sheet_1!B1=[Workbook_2]Sheet_2!B1,".",FALSE). Then, just fill down the formula (dragging down).
Note: . is used for easiness of distinguishing FALSE values.

VBA - sum totals to a master worksheet

Okay, so here goes. I have a workbook with individual worksheets for each day detailing the stock trading activity. I also currently have a VBA which provides a sum total for specified columns on each of these worksheets, and this works fine.
However, what I would like to do is add to my VBA so that it provides a sum total for these columns into the master worksheet.
So, for example: If there was trading activity totalling 4m on the 1st Oct 2018 on worksheet 1, and trading activity totalling 3m on 2nd october 2018 on worksheet 2, I would like to have this total of 7m shown on the master worksheet.
I've attached my current vba below, the column currently being summed on each individual worksheet is J. The columns summed on the individual worksheet do not change, however the amount of data contained in those columns obviously does depending on trading activity.
Sub autoSum_AllSheets()
Dim ws As Worksheet
Dim cel1 As String, cel2 As String
Dim firstCel As Range
For Each ws In ActiveWorkbook.Worksheets
With ws
Set firstCel = .Range("J3").End(xlDown).Offset(2, 0)
cel1 = firstCel.Offset(-2, 0).End(xlUp).Address
cel2 = firstCel.Offset(-1).Address
firstCel.Value = "=SUM(" & cel1 & ":" & cel2 & ")"
End With
Next ws
End Sub
I've also attached a screenshot of a current mock worksheet taken from a random day, with the sum total i get after running the vba bolded and highlighted in red.
Any advice on how to approach this would be great as I'm a newcomer to all things VBA.
Edit: I've attached a mock screenshot of what I'm trying to achieve on the master worksheet below:
I recommend the following …
Option Explicit
Public Sub AutoSumAllWorkheets()
Const MasterName As String = "Master" 'specify name of master sheet
Dim wsMaster As Worksheet
On Error Resume Next 'test if master exists
Set wsMaster = ActiveWorkbook.Worksheets(MasterName)
On Error GoTo 0
If wsMaster Is Nothing Then 'add master if not exists
Set wsMaster = ActiveWorkbook.Worksheets.Add(Before:=ActiveWorkbook.Worksheets(1))
wsMaster.Name = MasterName
'instead you can throw a message and exit here
'MsgBox "No master found"
'Exit Sub
End If
Dim FirstCell As Range, LastCell As Range
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
With ws
If .Name <> MasterName Then 'don't sum on master sheet
Set FirstCell = .Range("J3")
Set LastCell = FirstCell.End(xlDown)
LastCell.Offset(2, 0).Formula = "=SUM(" & FirstCell.Address & ":" & LastCell.Address & ")"
'write in master
With wsMaster.Cells(wsMaster.Rows.Count, "A").End(xlUp)
.Offset(1, 0).Value = ws.Name
.Offset(1, 1).Formula = "=" & LastCell.Offset(2, 0).Address(External:=True)
End With
End If
End With
Next ws
'sum all sheets up
With wsMaster.Cells(wsMaster.Rows.Count, "A").End(xlUp)
.Offset(2, 0).Value = "Total sum:"
.Offset(2, 1).Formula = "=SUM(" & wsMaster.Cells(1, "B").Address & ":" & .Offset(0, 1).Address & ")"
End With
End Sub
The first part checks if a master sheet exists and adds one if it doesn't exist.
Then I improved your code a bit:
I recommend to use clear variable names (makes it easier). For example your firstCel actually was not the first but the sum cell. That is very confusing and you will easily fail.
Use .Formula to write a formula.
I added some code to write the sums of each sheet into the master sheet. Note that this appends the entries at the master sheet. So if you run it twice you need to clear the entries in the master sheet first.
If you want to write into another column of the master sheet just change the column name of wsMaster.Cells(wsMaster.Rows.Count, "A").End(xlUp) from "A" to eg "L"
Try:
Sub test4()
Dim ws As Worksheet
Dim LastRowJ As Long
Dim MasterTotal As Double
For Each ws In ActiveWorkbook.Worksheets
LastRowJ = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row
MasterTotal = MasterTotal + ws.Range("J" & LastRowJ).Value '<= Let us assume that total appears in each sheet at the last line in column J
Next ws
Sheet1.Range("A1").Value = MasterTotal '<= Change where you want to import the total of totals
End Sub

Copy rows in Excel if cell contains name from an array

I have an Excel sheet that contains entries for ~150 employees. Each row contains the name as well as hours worked, pay, team, etc etc etc etc. The B column in each row contains the employees name in Last,First format. About half the employees on the sheet are part time employees. What i'm trying to do is write a macro in VB that copies the entire row if the name in the B column matches one of the names of the part time employees so that one of my coworkers can simply run the macro and paste all of the rows of copied users into a new sheet each week. Here's what I currently have. (I have all of the employees names in the array however I have censored them out) I really don't understand much of the last 50% of the code. This stuff was stuff I found online and have been messing around with.
`Sub PartTime()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
nameArray = Array(NAMES CENSORED)
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("C" & I & ":F" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub`
This code should work for what you are looking for. It is important to note that the string names in your array must be identical to that in Column B (with the exception of leading and trailing spaces), so if the names are written "LastName, FirstName" then your input data must be identical. This code could be tweaked to not have this requirement, but for now I've left it as such. Let me know if you'd prefer the code be adjusted.
Option Explicit
Sub PartTimeEmployees()
Dim NewSheet As Worksheet, CurrentSheet As Worksheet, NameArray As Variant
Set CurrentSheet = ActiveWorkbook.ActiveSheet
Set NewSheet = Sheets.Add(After:=Sheets(Worksheets.Count))
NewSheet.Name = "Part Time Employees"
NameArray = Array("NAMES CENSORED")
'Pulling headers from the first row
CurrentSheet.Rows(1).EntireRow.Copy
NewSheet.Select 'Redundant but helps avoid the occasional error
NewSheet.Cells(1, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
Dim NextRow As Long
NextRow = 2
'Writing this code to not assume that the data is continuous
Dim Count As Long
'Iterating to the end of the data in the sheet
For Count = 2 To CurrentSheet.UsedRange.Rows.Count
If Not IsEmpty(CurrentSheet.Cells(Count, 2)) Then
For Counter = 1 To UBound(NameArray)
'Performing string operations on the text will be faster than the find method
'It is also essential that the names are entered identically in your array
If UCase(Trim(CurrentSheet.Cells(Count, 2).Value)) = UCase(NameArray(Counter)) Then
CurrentSheet.Rows(Count).Copy
NewSheet.Select
NewSheet.Cells(NextRow, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
NextRow = NextRow + 1
Exit For
End If
Next Counter
End If
Next Count
End Sub
No need to loop through the array if you use a Range.AutoFilter Method with the array as criteria.
See comment for each line of operational code.
Option Explicit
Sub partTimers()
Dim nameArray As Variant
'construct an array of the part-time employees' names
nameArray = Array("Trgh, Evtfk", "Mtre, Sdnrm", _
"Sfgd, Pxduj", "Lsds, Qwrml", _
"Eqrd, Oqtts")
With Worksheets("Sheet1") 'you should know what worksheet the names are on
'turn off AutoFilter is there is one already in operation
If .AutoFilterMode Then .AutoFilterMode = False
'use the 'island' of cells radiating out from A1
With .Cells(1, 1).CurrentRegion
'apply AutoFilter using array of names as criteria
.AutoFilter field:=2, Criteria1:=nameArray, Operator:=xlFilterValues
'check if there is anything to copy
If Application.Subtotal(103, .Columns(2)) > 1 Then
'copy the filtered range
.Cells.Copy
'create a new worksheet
With .Parent.Parent.Worksheets.Add(After:=Sheets(Sheets.Count))
'paste the filtered range, column widths and cell formats
.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
End With
End If
End With
'turn off the AutoFilter
If .AutoFilterMode Then .AutoFilterMode = False
'turn off active copy range
Application.CutCopyMode = False
End With
End Sub

Resources