Related
I have a good basic script that returns me the sheet name of each sheet in the workbook, but now I'd like to add the contents of cell A1, A2, A3, and A4 into columns B, C, D, and E and add a header row with "Link, Variable, Definition, Calculation, Notes" in columns A, B, C, D. The existing hyperlink will be in column A.
It will need to loop through the entire workbook, and if possible skip adding a link to the table of contents page. Here is a basic script I currently use (borrowed from Extend Office) -
'updateby Extendoffice 20180413
Dim xAlerts As Boolean
Dim I As Long
Dim xShtIndex As Worksheet
Dim xSht As Variant
xAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Table of contents").Delete
On Error GoTo 0
Set xShtIndex = Sheets.Add(Sheets(1))
xShtIndex.Name = "Table of contents"
I = 1
Cells(1, 1).Value = "Table of contents"
For Each xSht In ThisWorkbook.Sheets
If xSht.Name <> "Table of contents" Then
I = I + 1
xShtIndex.Hyperlinks.Add Cells(I, 1), "", "'" & xSht.Name & "'!A1", , xSht.Name
End If
Next
Application.DisplayAlerts = xAlerts
End Sub
Not sure if this does exactly what you want, there is some gaps in the explanation in regards how you want to handle the link fucntion. Since you mention the code "works" but you want some added function, and you dont want links on the "table of contents" but it doesn't do that now either?
anyway give this a go...
Private Sub CommandButton1_Click()
Dim xAlerts As Boolean
Dim I As Long
Dim xShtIndex As Worksheet
Dim Table As Worksheet
Dim xSht As Variant
xAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Table of contents").Delete
On Error GoTo 0
Set xShtIndex = Sheets.Add(Sheets(1))
xShtIndex.Name = "Table of contents"
Set Table = Worksheets("Table of contents")
I = 2
targetcolumn = 1
'Cells(1, 1).Value = "Table of contents"
'Disabled this because i'm not sure if this code should be here?
For Each xSht In ThisWorkbook.Sheets
With xSht
If xSht.Name = "Table of contents" Then
.Cells(1, 1).Value = "Table of contents"
.Range("A1").Value = "Link"
.Range("B1").Value = "Variable"
.Range("C1").Value = "Definition"
.Range("D1").Value = "Calculation"
.Range("E1").Value = "Notes"
End If
If xSht.Name <> "Table of contents" Then
lrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Dim copyrng As Range
Set copyrng = .Range("A1:A" & lrow)
copycount = 2 'skipping one because with 1 it would write to row 1 which is where the headers are
For Each cell In copyrng
Table.Cells(targetcolumn, copycount).Value = cell.Value
copycount = copycount + 1
Next
Table.Hyperlinks.Add Table.Cells(I, 1), "", "'" & xSht.Name & "'!A1", , xSht.Name
I = I + 1
End If
End With
targetcolumn = targetcolumn + 1
Next
Application.DisplayAlerts = xAlerts
End Sub
I want the values in Column D to change depending upon the value in Column A. Some values do not need to be amended at all if the conditions aren't met
Sub Test()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim row As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
I think I have an error in the lines beginning with c.Value = c.Value * .....
I'm new to VBA and just trying to make sense of it
I just provide this variant. It is working with array, so theoretically it is very quick. Probably no need to turn off the screen updating.
Sub test()
Dim lastRow As Long, i As Long
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
Dim vA As Variant 'Represents A2-A lastrow
vA = .Range("A2").Resize(lastRow - 1).Value
Dim vb As Variant 'Represents D2-D lastrow
vb = .Range("D2").Resize(lastRow - 1).Value
i = 0
Dim v As Variant
For Each v In vA
i = i + 1
If v = "Bol" Then
vb(i, 1) = vb(i, 1) * 1.19
ElseIf v = "Amazon" Then
vb(i, 1) = vb(i, 1) * 1.2
End If
Next v
.Range("D2").Resize(lastRow - 1).Value = vb ' Writing the values to the D column
End With
End Sub
You have to forecast and handle all possible conditions. Use this code please:
Sub Test()
Application.ScreenUpdating = False
Dim row As Integer
Dim Lastrow As Long
'I've assumed that you are working on sheet1
Lastrow = Sheets(1).Cells(Rows.Count, "D").End(xlUp).row
If Lastrow > 1 Then
For row = 2 To Lastrow
If Sheets(1).Cells(row, 1).Value = "Bol" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.19
End If
If Sheets(1).Cells(row, 1).Value = "Amazon" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.2
End If
Next
Else
MsgBox ("There is no data at column D")
End If
Application.ScreenUpdating = True
End Sub
There are quite a few ways to go about what you're trying to do. For what it's worth, this is how I would go about it. You had a few additional variables you didn't need, and your 'row' variable wasn't assigned a value at all.
Sub test2()
Dim lastRow As Long, _
i As Long
Application.ScreenUpdating = False
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
For i = 2 To lastRow
If .Cells(i, 1).Value = "Bol" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.19
End If
If .Cells(i, 1).Value = "Amazon" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.2
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
I kept is relatively simple, so hopefully you can follow what's going on. If you have a lot of "If" statements, it may be cleaner to use VBAs "Select Case".
Also the text strings as you have them set up are case sensitive. "Bol" does not equal "bol" maybe that doesn't matter, but something to be aware of. If the string you pass it is "amazon" it will not pass the 'If' test.
Another assumption I made was that your data is on Sheet1. You should get in the habit of fully qualifying your ranges, it will make your life a lot easier as your code gets more complicated.
Last bit, I'm assuming the values in column D are all numbers. If there is text in there, you may run in to problems multiplying it.
Good luck!
You can simplify your code, and make it easier to read, by looping trough column A instead of column D and using the If/ElseIf statement to test each cell for either of the two conditions. By setting your range and defining c as a range variable for each cell in the range, you only have to loop through each cell and test for the two conditions. If the cell contains Bol use the Offset property to multiple the current value in column D by 1.19; ElseIf the cell contains Amazon use the Offset property to multiple the current value in column D by 1.2. Comments provide in the code.
Application.ScreenUpdating = False
'use the With statement to define your workbook and sheet, change as needed
'Note: "ThisWorkbook" identifies the workbook which contains this code
With ThisWorkbook.Sheets("Sheet1")
'Define the range you want to loop through, using the column you want to test
Dim rng As Range: Set rng = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
'Define the variable for each cell-range
Dim c As Range
'loop through each "c" in the range and if one of the conditions are met
For Each c In rng
If c = "Bol" Then
'then use the "Offset property" to modify the value in column D
c.Offset(, 3) = c.Offset(, 3).Value * 1.19
ElseIf c = "Amazon" Then
c.Offset(, 3) = c.Offset(, 3).Value * 1.2
End If
Next c
End With
Application.ScreenUpdating = True
In-Place Modification
All the solutions have one common issue: you can use them only once. If you need to change the values after adding new records (rows) you should consider adding another column with the initial values so the code could be written to identify what has already been changed and what not. But that's for another question.
Your Sub Solution
You actually had only one serious mistake in two-three places.
Instead of row in the If statements you should have used c.Row and you could have removed Dim row As Integer:
Sub Test_Almost_Fixed()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
Additionally after getting rid of the extra Application.ScreenUpdating = False and the Dim startrow As Integer and some further cosmetics, you could have had something like this:
Sub Test_Fixed()
Dim c As Range
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
Application.ScreenUpdating = False
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
A More Complex Sub Solution
Use the following for the ActiveSheet in a standard module (e.g. Module1). For a particular sheet you can place it in a sheet module (e.g. Sheet1) or create a button on the sheet.
Tip: When you have such a simple (short, fast) code and especially when you're using a Button to run it (in a 'one-time operation code'), it is good practice to use a MsgBox at the end of the code to actually know that the code has run and to prevent accidentally pressing the Button more than once.
Option Explicit
Sub Test()
Const Proc As String = "Test"
On Error GoTo cleanError
' Define Constants.
Const FirstRow As Long = 2
Const SourceColumn As Variant = 1 ' e.g. 1 or "A"
Const TargetColumn As Variant = 4 ' e.g. 4 or "D"
Dim Criteria As Variant ' Add more values.
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant ' Add more values.
Multiplier = Array(1.19, 1.2)
' Check if Criteria and Multiplier Arrays have the same number
' of elements (columns).
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
' Write Source and Target Ranges to Source and Target Arrays.
Dim rng As Range
' Define Last Non-Empty Cell.
Set rng = Columns(TargetColumn).Find("*", , xlValues, , , xlPrevious)
' Check if Target Column is empty.
If rng Is Nothing Then Exit Sub
' Check if the row of Last Non-Empty Cell is above FirstRow.
If rng.Row < FirstRow Then Exit Sub
Dim Target As Variant
' Write Target Range to Target Array.
Target = Range(Cells(FirstRow, TargetColumn), rng).Value
Set rng = Nothing
Dim ubST As Long: ubST = UBound(Target)
Dim Source As Variant
' Write Source Range to Source Array.
Source = Cells(FirstRow, SourceColumn).Resize(ubST).Value
' Modify Target Array.
Dim i As Long, j As Long
' Loop through elements (rows) of Source and Target Arrays.
For i = 1 To ubST
' Loop through elements (columns) of Criteria and Multiplier Arrays.
For j = 0 To ubCM
' Check if the value in current element (row) of Source Array
' matches the value of current element (column) in Criteria Array.
If Source(i, 1) = Criteria(j) Then
' Modify value in current element (row) of Target Array
' by multiplying it with the value of current element (column)
' of Multiplier Array.
Target(i, 1) = Target(i, 1) * Multiplier(j)
' Since a match is found, there is no need to loop anymore.
Exit For
End If
Next j
Next i
Erase Source
' Write values of Target Array to Target Range.
Cells(FirstRow, TargetColumn).Resize(ubST).Value = Target
Erase Target
' Inform user.
MsgBox "Data copied.", vbInformation, "Success"
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
End Sub
An Event Solution
To make it automatically change the values in column D for each change of a value in column A you can place the following code into the sheet module (e.g. Sheet1):
Option Explicit
Private Const SOURCE_COLUMN As Variant = 1 ' e.g. 1 or "A"
Private Const TARGET_COLUMN As Variant = 4 ' e.g. 4 or "D"
Private Sub sdfWorksheet_Change(ByVal Target As Range)
Const Proc As String = "Worksheet_Change"
On Error GoTo cleanError
If Intersect(Columns(SOURCE_COLUMN), Target) Is Nothing Then Exit Sub
Const FirstRow As Long = 2
Dim rng As Range
Set rng = Columns(TARGET_COLUMN).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRow Then Exit Sub
Set rng = Cells(FirstRow, SOURCE_COLUMN).Resize(rng.row - FirstRow + 1)
If Intersect(rng, Target) Is Nothing Then Exit Sub
Dim cel As Range
Application.Calculation = xlCalculationManual ' -4135
For Each cel In Target.Cells
TestChange cel
Next cel
CleanExit:
Application.Calculation = xlCalculationAutomatic ' -4105
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
Private Sub TestChange(SourceCell As Range)
Const Proc As String = "TestChange"
On Error GoTo cleanError
Dim Criteria As Variant
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant
Multiplier = Array(1.19, 1.2)
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
Application.ScreenUpdating = False
Dim TargetCell As Range, j As Long
For j = 0 To ubCM
If SourceCell.Value = Criteria(j) Then
Set TargetCell = Cells(SourceCell.row, TARGET_COLUMN)
TargetCell.Value = TargetCell.Value * Multiplier(j)
Exit For
End If
Next j
CleanExit:
Application.ScreenUpdating = True
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
I have a worksheet (Sheet 1) that contains a help column AR that contains the number "5" or text "Invalid". I want column AS to do a specific vlookup if AR contains the number "5", but if it contains the text "invalid" to do a separate specific vlookup. Currently what I have just overwrites to what is done in the else section of my loop to be the last iteration over the column and just ends up doing a vlookup for one or the other. I'm using column Y in sheet 1 as the specific value (aCell) that is being used to vlookup. Any help would go a long way, thanks!
Dim wsThis As Worksheet
Dim aCell As Range
Set wsThis = Sheets("Sheet3")
Dim wsAnd As Worksheet
Set wsAnd = Sheets("Sheet2")
Dim LastRow As Long, myRng As Range
LastRow = Sheets("Sheet3").UsedRange.Rows.Count
With wsIt
For x = 2 To LastRow
If Sheets("Sheet1").Range("$AR$" & x) = "5" Then
For Each aCell In wsIt.Range("Y2:Y" & LastRow)
.Cells(aCell.Row, 45) = "Not Found"
On Error Resume Next
.Cells(aCell.Row, 45) = Application.WorksheetFunction.VLookup( _
aCell.Value, wsThis.Range("$B$2:$Q$400"), 5, False)
On Error GoTo 0
Next aCell
End If
Next
End With
With wsIt
For x = 2 To LastRow
If Sheets("Sheet1").Range("$AR$" & x) = "Invalid" Then
For Each aCell In wsIt.Range("Y2:Y" & LastRow)
.Cells(aCell.Row, 45) = "Not Found"
On Error Resume Next
.Cells(aCell.Row, 45) = Application.WorksheetFunction.VLookup( _
aCell.Value, wsAnd.Range("$B$2:$Q$400"), 5, False)
On Error GoTo 0
Next aCell
End If
Next
End With
If I correctly intended your aim, you could:
use Application.VlookUp() method to benefit from its returned value capture any error and query it
use a Select Case block to formerly choose the lookUp range in relation with column “AR” value
Dim wsIt As Worksheet
Set wsIt = Sheets("Sheet1")
Dim wsThis As Worksheet
Set wsThis = Sheets("Sheet3")
Dim wsAnd As Worksheet
Set wsAnd = Sheets("Sheet2")
Dim LastRow As Long
Dim aCell As Range
Dim lookUpResult As Variant
LastRow = wsThis.UsedRange.Rows.Count
With wsIt
For x = 2 To LastRow
Select Case .Cells(x, "AR")
Case "5"
Set VLookUpRng = wsThis.Range("$B$2:$Q$400")
Case “Invalid”
Set VLookUpRng = wsAnd.Range("$B$2:$Q$400")
Case Else
Set VLookUpRng = Nothing
End Select
If Not VLookUpRng Is Nothing Then
For Each aCell In .Range("Y2:Y" & LastRow)
lookUpResult = Application.VLookup( aCell.Value, VLookUpRng, 5, False)
.Cells(aCell.Row, 45) = IIf(IsError(lookUpResult), "Not Found", lookUpResult)
Next
End If
Next
End With
This wasnt a great solution but essentially I pasted over the vlookup results of the 2nd iteration into a new sheet and then sorted the columns of sheet 1 and sheet 2 such that the results would reference each other correctly.
Dim x as Long
Dim y As Long
Dim LastRow
Dim NewLast
LastRow = Sheets("Sheet1").UsedRange.Rows.Count
NewLast = Sheets("Sheet2").UsedRange.Rows.Count
For x = 2 to LastRow
If Sheets("Sheet1").Range("$AS$" & x) = "Not Found" Then
For y = 2 To NewLast
Sheets("Sheet1").Range("$AS$" & x) = Sheets("Sheet2").Range("$F$" & y)
Sheets("Sheet1").Range("$AT$" & x) = Sheets("Sheet2").Range("$F$" & y)
Next
End If
Next
I'm looking for VBA code that looks at the values in column A and if they are the same, merges the cells in columns F & G in the same rows.
I have no idea how to do this.
You could use this code:
Sub mergeFG()
Dim cell As Range
Dim cell2 As Range
Set cell = Range("A2")
Do While cell.Value <> ""
Set cell2 = cell.Offset(1)
Do While cell2.Value = cell.Value
Set cell2 = cell2.Offset(1)
Loop
Application.DisplayAlerts = False
cell.Offset(0, 5).Resize(cell2.Row - cell.Row).Merge
cell.Offset(0, 6).Resize(cell2.Row - cell.Row).Merge
Application.DisplayAlerts = True
Set cell = cell2
Loop
End Sub
Call mergeFG, either via other code, or link some button to it.
Check the code below. I have assumed that you have sorted Column-A i.e, ref_num and also change the SheetName from "Sample" in code to your workbook sheet name.
Sub merge_cells()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim counter As Integer
Set ws = ThisWorkbook.Worksheets("Sample")
end_row = ws.Range("A65536").End(xlUp).Row
counter = 1
For i = 2 To end_row
If ws.Range("A" & i).Value = ws.Range("A" & i - 1).Value Then
counter = counter + 1
Else
If counter > 1 Then
ws.Range("F" & i - counter).Resize(counter).Merge
ws.Range("G" & i - counter).Resize(counter).Merge
End If
counter = 1
End If
Next i
Application.ScreenUpdating = True
End Sub
I currently have a macro that compares two sheets together and highlights the differences. Can someone please help me complete the next function where it outputs to a 3rd document with the differences already highlighted?
Column A contains a unique ID on both Sheet1(new) and Sheet2(old). currently Sheet1 will have new IDs highlighted in green, while changes in existing IDs will be highlighted in yellow wherever the change is.
I've been trying to add the next code where the highlighted differences become generated on 3rd sheet and shows the change but no luck.
Excuse me for my bad programming logic...
Sub Compare()
Compare Macro
Const ID_COL As Integer = 1 'ID is in this column
Const NUM_COLS As Integer = 120 'how many columns are being compared?
Dim shtNew As Excel.Worksheet, shtOld As Excel.Worksheet, shtChange As Excel.Worksheet
Dim rwNew As Range, rwOld As Range, f As Range, rwRes As Range
Dim x As Integer, Id
Dim valOld, valNew
Set dict = CreateObject("Scripting.Dictionary")
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Change Report"
Range("A1").Select
ActiveCell.FormulaR1C1 = "Change Type"
Selection.Font.Bold = True
Columns("A:A").EntireColumn.AutoFit
Range("B1").Select
ActiveCell.FormulaR1C1 = "ID"
Selection.Font.Bold = True
Columns("B:B").EntireColumn.AutoFit
Range("C1").Select
ActiveCell.FormulaR1C1 = "Name"
Selection.Font.Bold = True
Columns("C:C").EntireColumn.AutoFit
Range("D1").Select
ActiveCell.FormulaR1C1 = "Product"
Selection.Font.Bold = True
Columns("D:D").EntireColumn.AutoFit
Range("E1").Select
ActiveCell.FormulaR1C1 = "Old"
Selection.Font.Bold = True
Columns("E:E").EntireColumn.AutoFit
Range("F1").Select
ActiveCell.FormulaR1C1 = "New"
Selection.Font.Bold = True
Columns("F:F").EntireColumn.AutoFit
Range("G1").Select
ActiveCell.FormulaR1C1 = "Difference"
Selection.Font.Bold = True
Columns("G:G").EntireColumn.AutoFit
Sheets("Sheet1").Select
Set shtNew = ActiveWorkbook.Sheets("Sheet1")
Set shtOld = ActiveWorkbook.Sheets("Sheet2")
Set shtChange = ActiveWorkbook.Sheets("Change Report")
ActiveWorkbook.Worksheets("Sheet1").AutoFilterMode = False
ActiveWorkbook.Worksheets("Sheet2").AutoFilterMode = False
ActiveWorkbook.Worksheets("Change Report").AutoFilterMode = False
Set rwNew = shtNew.Rows(2) 'first entry on "current" sheet
Set rwRes = shtChange.Rows(2)
ActiveWorkbook.Worksheets("Sheet1").AutoFilterMode = False
ActiveWorkbook.Worksheets("Sheet2").AutoFilterMode = False
Do While rwNew.Cells(ID_COL).Value <> "" 'Compares new Sheet to old Sheet
rwRes.EntireRow(x).Value = rwNew.EntireRow(x).Value
Id = rwNew.Cells(ID_COL).Value
Set f = shtOld.UsedRange.Columns(ID_COL).Find(Id, , xlValues, xlWhole)
If Not f Is Nothing Then
Set rwOld = f.EntireRow
For x = 1 To NUM_COLS
r = 1
If rwNew.Cells(x).Value <> rwOld.Cells(x).Value Then
rwNew.Cells(x).Interior.Color = vbYellow
'rwRes.Cells(r, 2).Value = rwNew.Cells(x, 1).Value 'ID
'rwRes.Cells(r, 3).Value = rwNew.Cells(x, 11).Value 'Name
'rwRes.Cells(r, 4).Value = rwNew.Cells(x, 12).Value 'Product
'rwRes.Cells(r, 5).Value = rwOld.Cells(x, 14).Value 'Price old
'rwRes.Cells(r, 6).Value = rwNew.Cells(x, 14).Value 'Price new
'Percentage Change from old to new 'Difference
r = r + 1
Else
rwNew.Cells(x).Interior.ColorIndex = xlNone
End If
Next x
Else
rwNew.EntireRow.Interior.Color = vbGreen 'new entry
'rwRes.Cells(r, x).Value = rwNew.Cells(x, 1).Value
'rwRes.Cells(r, 2).Value = rwNew.Cells(x, 1).Value 'ID
'rwRes.Cells(r, 3).Value = rwNew.Cells(x, 11).Value 'Name
'rwRes.Cells(r, 4).Value = rwNew.Cells(x, 12).Value 'Product
'rwRes.Cells(r, 6).Value = rwNew.Cells(x, 14).Value 'Price
r = r + 1
End If
Set rwNew = rwNew.Offset(1, 0) 'next row to compare
Loop
Selection.AutoFilter
MsgBox ("Complete")
End Sub
As an alternative to the solution posted by Thomas, you can make use of dictionaries to store indexes for each unique ID, and relevant columns. By population of the dictionaires in loops based on the hardcoded arrays (vHeader and vLookFor) and the range.find method, this enables you to change the position of columns and to some extent behaviour of the code without having to worry about indexes further down.
The script first populates up the dictionaries for header and ID's for the new and old sheets, and then loops the new ID keys to find the ones that had a change to any of the fields set as relevant in the vLookFor, and the ones that are brand new.
The use of the function columnLetter in the creation of the shtChange header range ensures that if you add a field to the vheader it will automatically be added to the shtChange.To avoid having to remove the shtChange in case you want to rerun the macro, I've added a doExist function - it simply deletes the sheet and returns a new worksheet object of the same name.
In case a difference, or a new field is identified, the line is moved to the shtChange and the difference calculated (New price/Old price in %).
Changing the order of columns would at the present wreck you field by field check for all 120 columns, but you could update this to use a dictionary, or more specifically range.find, mitigating the sort of stuff users tend to do (moving columns, sorting etc.) - but blame you for.
Sub Compare()
'reference to Microsoft scripting runtime is a prerequisite for Dictionaries to work
'can the shtOld.usedrange.columns.count potentially substitute this hardcode?
Const ID_COL As Integer = 1 'ID is in this column
Const NUM_COLS As Integer = 120 'how many columns are being compared
Dim shtNew As Worksheet, shtOld As Worksheet, shtChange As Worksheet
Dim vHeader As Variant
Dim vLookFor As Variant
Dim vElement As Variant
Dim vKeyID As Variant
Dim vKeyValueIdx As Variant
Dim oldRowIdx As Variant
Dim oldColIdx As Variant
Dim newRowIdx As Variant
Dim newColIdx As Variant
Dim chgRowIdx As Long
Dim oldPriceIdx As Long
Dim newPriceIdx As Long
Dim diffPriceIdx As Long
Dim chgTypeIdx As Long
Dim shtChangeName As String
Dim oldIndexDict As Dictionary
Dim oldIdRowDict As Dictionary
Dim newIndexDict As Dictionary
Dim newIdRowDict As Dictionary
Dim chgIndexDict As Dictionary
Dim i As Long, j As Long, k As Long, m As Long, n As Long
Dim x As Integer, Id
Dim valOld, valNew
'some intital parameters
shtChangeName = "Change Report"
'rather than printing the header one value at a time, then you can simply place an array directly into the range
vHeader = Array("Change Type", "ID", "Name", "Product", "Old Price", "New Price", "Difference")
'we create a array for the headers that we will be looking for, for the shtChange
vLookFor = Array("ID", "Name", "Product", "Price")
'setting the worksheet object
Set shtNew = ThisWorkbook.Sheets("Sheet1")
Set shtOld = ThisWorkbook.Sheets("Sheet2")
'add the shtChange
Set shtChange = doExist(shtChangeName) 'I really hate having to manually delete a worksheets in case I want to rerun, so I added the doExist function to delete the sheet if it allready exist
'disable any data fitler
shtNew.AutoFilterMode = False
shtOld.AutoFilterMode = False
'Generating the bold headers for the change sheet, to avoid retyping the range over and over again, we use with
With shtChange.Range("A1:" & ColumnLetter(UBound(vHeader) + 1) & "1") 'this is implicitly repeated for all rows, e.g. '.value' -> 'shtChange.Range("A1:G1").value'
.Value = vHeader
.Font.Bold = True
End With
'I will be using dictionaries to find my way around the position of specific headers and ID's. This I do for added robustness, in case the business decides to move columns, change the sorting etc. in only the old or new sheet
Set oldIndexDict = CreateObject("Scripting.Dictionary") 'for header index
Set oldIdRowDict = CreateObject("Scripting.Dictionary") 'for ID row index
Set newIndexDict = CreateObject("Scripting.Dictionary") 'for header index
Set newIdRowDict = CreateObject("Scripting.Dictionary") 'for ID row index
Set chgIndexDict = CreateObject("Scripting.Dictionary") 'for header index
'we populate the index dictionaries
For Each vElement In vLookFor
If Not newIndexDict.Exists(CStr(vElement)) Then
oldIndexDict.Add CStr(vElement), shtOld.Range("1:1").Find(what:=CStr(vElement), LookIn:=xlValues, LookAt:=xlWhole).Column
newIndexDict.Add CStr(vElement), shtNew.Range("1:1").Find(what:=CStr(vElement), LookIn:=xlValues, LookAt:=xlWhole).Column
On Error Resume Next
chgIndexDict.Add CStr(vElement), shtChange.Range("1:1").Find(what:=CStr(vElement), LookIn:=xlValues, LookAt:=xlWhole).Column
On Error GoTo 0
End If
Next
'In case the data is not ordered exactly the same in the new and old sheets, we populate the IdRow dictionaries to enable us to find the position of a specific ID in either sheet
'first the oldSht
For i = 2 To shtOld.UsedRange.Rows.Count 'be aware that if your data does not start on row 1, the usedrange will not accurately reflect the true last row number
If Not oldIdRowDict.Exists(CStr(shtOld.Cells(i, oldIndexDict("ID")))) And CStr(shtOld.Cells(i, oldIndexDict("ID"))) <> "" Then
oldIdRowDict.Add CStr(shtOld.Cells(i, oldIndexDict("ID"))), i
End If
Next
'then the newSht
For j = 2 To shtNew.UsedRange.Rows.Count 'be aware that if your data does not start on row 1, the usedrange will not accurately reflect the true last row number
If Not newIdRowDict.Exists(CStr(shtNew.Cells(j, newIndexDict("ID")))) And CStr(shtNew.Cells(j, newIndexDict("ID"))) <> "" Then
newIdRowDict.Add CStr(shtNew.Cells(j, newIndexDict("ID"))), j
End If
Next
'get indexes for fields specific for shtChange
chgTypeIdx = shtChange.Range("1:1").Find(what:="Change Type", LookIn:=xlValues, LookAt:=xlWhole).Column 'index for changetype
oldPriceIdx = shtChange.Range("1:1").Find(what:="Old Price", LookIn:=xlValues, LookAt:=xlWhole).Column 'index for old price
newPriceIdx = shtChange.Range("1:1").Find(what:="New Price", LookIn:=xlValues, LookAt:=xlWhole).Column 'indexd for new price
diffPriceIdx = shtChange.Range("1:1").Find(what:="Difference", LookIn:=xlValues, LookAt:=xlWhole).Column 'index for difference column
'then we loop the keys in the New sheet and make the relevant comparision, incl. move to shtChange
For Each vKeyID In newIdRowDict.Keys
'retrieve the relevant indexes for the columns going into the shtChange
newRowIdx = newIdRowDict(vKeyID)
If oldIdRowDict.Exists(vKeyID) Then
oldRowIdx = oldIdRowDict(vKeyID)
For Each vKeyValueIdx In newIndexDict.Keys
If shtOld.Cells(oldRowIdx, oldIndexDict(vKeyValueIdx)) <> shtNew.Cells(newRowIdx, newIndexDict(vKeyValueIdx)) Then
chgRowIdx = shtChange.UsedRange.Rows.Count + 1
shtChange.Cells(chgRowIdx, chgTypeIdx) = "Update" 'the key allready existed in the old sheet, so update
For m = LBound(vLookFor) To UBound(vLookFor)
If chgIndexDict.Exists(vLookFor(m)) Then
shtChange.Cells(chgRowIdx, chgIndexDict(vLookFor(m))) = shtNew.Cells(newRowIdx, newIndexDict(vLookFor(m)))
End If
Next
shtChange.Cells(chgRowIdx, oldPriceIdx) = shtOld.Cells(oldRowIdx, oldIndexDict("Price"))
shtChange.Cells(chgRowIdx, newPriceIdx) = shtNew.Cells(newRowIdx, newIndexDict("Price"))
shtChange.Cells(chgRowIdx, diffPriceIdx) = shtChange.Cells(chgRowIdx, newPriceIdx) / shtChange.Cells(chgRowIdx, oldPriceIdx)
End If
Next
shtChange.Columns(diffPriceIdx).NumberFormat = "0.0%"
'This is subject to risk of moved columns etc., but to retain functionality of the posted code we loop all columns the respective ID, and set the colors
For k = 1 To NUM_COLS
If shtOld.Cells(oldRowIdx, k).Value <> shtNew.Cells(newRowIdx, k).Value Then
shtNew.Cells(newRowIdx, k).Interior.Color = vbYellow
Else
shtNew.Cells(newRowIdx, k).Interior.ColorIndex = xlNone
End If
Next
Else 'it is a new entry
shtNew.Range("A" & newRowIdx).EntireRow.Interior.Color = vbGreen 'new entry
chgRowIdx = shtChange.UsedRange.Rows.Count + 1
For n = LBound(vLookFor) To UBound(vLookFor) 'loops the elements of the search fields, and if they exist in shtChange, we fetch the value from shtNew
If chgIndexDict.Exists(vLookFor(n)) Then
shtChange.Cells(chgRowIdx, chgIndexDict(vLookFor(n))) = shtNew.Cells(newRowIdx, newIndexDict(vLookFor(n)))
End If
Next
shtChange.Cells(chgRowIdx, chgTypeIdx) = "New" 'key is new, so New
shtChange.Cells(chgRowIdx, newPriceIdx) = shtNew.Cells(newRowIdx, newIndexDict("Price")) 'since the element is new, only the new price is relevant for shtChange
End If
Next
shtChange.Range("A1:G1").Columns.AutoFit
shtChange.Range("A1").AutoFilter
'set the dicts to nothing
Set oldIndexDict = Nothing
Set oldIdRowDict = Nothing
Set newIndexDict = Nothing
Set newIdRowDict = Nothing
Set chgIndexDict = Nothing
MsgBox ("Complete")
End Sub
Function doExist(strSheetName) As Worksheet
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsTest As Worksheet
Dim nWs As Worksheet
Set wsTest = Nothing
On Error Resume Next
Set wsTest = wb.Worksheets(strSheetName)
On Error GoTo 0
If Not wsTest Is Nothing Then
Application.DisplayAlerts = False
wsTest.Delete
Application.DisplayAlerts = True
End If
Set doExist = wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count))
doExist.Name = strSheetName
End Function
Function ColumnLetter(ColumnNumber As Long) As String
Dim n As Long
Dim c As Byte
Dim s As String
n = ColumnNumber
Do
c = ((n - 1) Mod 26)
s = Chr(c + 65) & s
n = (n - c) \ 26
Loop While n > 0
ColumnLetter = s
End Function
You're going to need to set a reference to the Microsoft Scripting Runtime.
This should be really close to what you want.
ProductRecord: Stores all the variable to be written to the new worksheet
dProducts: Is a dictionary that holds the ProductRecords
Iterate Sheet1 adding products to dProducts by ID if there they cells are colored
Iterate Sheet2 searching for dProducts by ID. If found we set the product's Old Price
Iterate Worksheet("Change Report") Pasting the products in dProducts as we go
Class ProductRecord
Option Explicit
Public ChangeType As String
Public ID As String
Public Name As String
Public Product As String
Public OldPrice As Double
Public NewPrice As Double
Public Difference As Double
Public Color As Long
Public Sub Paste(Destination As Range)
Dim arData(5)
Difference = NewPrice - OldPrice
If Color = vbGreen Then ChangeType = "New Product" Else ChangeType = "ID Change"
arData(0) = ChangeType
arData(1) = Name
arData(2) = Product
arData(3) = OldPrice
arData(4) = NewPrice
arData(5) = Difference
Destination.Resize(1, 6) = arData 'WorksheetFunction.Transpose(arData)
Destination.Interior.Color = Color
End Sub
The rest of the story
Option Explicit
Sub Compare()
ToggleEvents False
Dim shtNew As Excel.Worksheet, shtOld As Excel.Worksheet, shtChange As Excel.Worksheet
Dim rwNew As Range
Dim k As String
Dim lastRow As Long, x As Long, y
Dim Product As ProductRecord
Dim dProducts As Dictionary
Set dProducts = New Dictionary
Set shtNew = Sheets("Sheet1")
Set shtOld = Sheets("Sheet2")
shtNew.AutoFilterMode = False
shtOld.AutoFilterMode = False
With shtNew
lastRow = .Range("A" & Rows.Count).End(xlUp).Row
For x = 2 To lastRow
For Each y In Array(1, 11, 12, 14)
If .Cells(x, y).Interior.color = vbYellow Or .Cells(x, y).Interior.color = vbGreen Then
Set Product = New ProductRecord
k = .Cells(x, 1).Value
Product.color = .Cells(x, y).Interior.color
Product.ID = .Cells(x, 1).Value 'ID
Product.Name = .Cells(x, 11).Value 'Name
Product.Product = .Cells(x, 12).Value 'Product
Product.NewPrice = .Cells(x, 14).Value 'Price old
If Not dProducts.Exists(k) Then
dProducts.Add k, Product
Exit For
End If
End If
Next
Next
End With
If dProducts.Count > 0 Then
With shtOld
lastRow = .Range("A" & Rows.Count).End(xlUp).Row
For x = 2 To lastRow
k = .Cells(x, 1).Value
If dProducts.Exists(k) Then
dProducts(k).OldPrice = .Cells(x, 14).Value 'ID
End If
Next
End With
End If
Set shtChange = getChangeReportWorkSheet
With shtChange.Range("A1:G1")
.Value = Array("Change Type", "ID", "Name", "Product", "Old", "New", "Difference")
Selection.Font.Bold = True
End With
With shtChange
lastRow = dProducts.Count - 1
For x = 0 To lastRow
dProducts.Items(x).Paste .Cells(x + 2, 1)
Next
.Range("A1:G1").EntireColumn.AutoFit
End With
ToggleEvents True
'Selection.AutoFilter
MsgBox ("Complete")
End Sub
Sub ToggleEvents(EnableEvents As Boolean)
With Application
.EnableEvents = EnableEvents
.Calculation = IIf(EnableEvents, xlCalculationAutomatic, xlCalculationManual)
End With
End Sub
Function getChangeReportWorkSheet() As Worksheet
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Change Report").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set getChangeReportWorkSheet = Sheets.Add(After:=Sheets(Sheets.Count))
getChangeReportWorkSheet.Name = "Change Report"
End Function