Im trying to create a table that pulls data from my raw data if certain conditions are met. The code I currently have does not seem to be working.
Public Sub insert_rows()
Dim datasheet As Worksheet
Dim datasheet2 As Worksheet
Dim r As Long
Dim tableA As ListObject
Set tableA = Worksheets(Sheet7).ListObject(Preventable)
Set datasheet = Worksheets(Sheet7)
Set datasheet2 = Worksheets("Data")
With datasheet2
nr = Cells(Rows.Count, 1).End(x1up).Row
For r = 1 To nr
If Cells(r, 17) = "Y" Then
Cells(r, 16).Copy Destination:=Sheets("Sheet7").Range("B4")
End If
Next
End With
End Sub
Basically I have several worksheets and need to pull data from one of them to add to this table in another worksheet. My condition is if the Column in the raw data worksheet contains "Y", then pull cell values into the table of the other worksheet. An image below is an example of the data I want to copy and paste over:
As you can see, they are string values separated by "," and can contain duplicates.
I only want to add just the unique entries into the new table; with no repetition of cells. Anyway I could modify this code to suit those conditions?
You could try something like this:
Public Sub insert_rows()
Dim datasheet As Worksheet
Dim datasheet2 As Worksheet
Dim r As Long, i As Long, nr As Long
Dim tableStartingRow As Long, currenttableitem As Long
Dim stringvalues As Variant
Dim stringseparator As String
Dim valueexists As Boolean
tableStartingRow = 4
stringseparator = ","
Set datasheet = Worksheets("Sheet7")
Set datasheet2 = Worksheets("Data")
With datasheet
currenttableitem = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
With datasheet2
nr = .Cells(.Rows.Count, 16).End(xlUp).Row
For r = 1 To nr
If .Cells(r, 17) = "Y" Then
If InStr(.Cells(r, 16), stringseparator) > 0 Then 'If value contains comma
stringvalues = Split(.Cells(r, 16), stringseparator)
For i = LBound(stringvalues) To UBound(stringvalues)
valueexists = False 'Reset boolean
For x = tableStartingRow To currenttableitem
If datasheet.Range("B" & x).Value = Trim(stringvalues(i)) Then
valueexists = True
Exit For
End If
Next x
If Not valueexists Then
currenttableitem = currenttableitem + 1
datasheet.Range("B" & currenttableitem).Value = Trim(stringvalues(i))
End If
Next i
Else
valueexists = False 'Reset boolean
For x = tableStartingRow To currenttableitem
If datasheet.Range("B" & x).Value = .Cells(r, 16).Value Then
valueexists = True
Exit For
End If
Next x
If Not valueexists Then
currenttableitem = currenttableitem + 1
datasheet.Range("B" & currenttableitem).Value = .Cells(r, 16).Value
End If
End If
End If
Next
End With
End Sub
This code will check each value of the cells and will split the contents by ",". Then compare with the content of the table to see if this value is already in there. In case it is not, it will be added, otherwise omitted.
Also, I notice the use of the Cells inside of a With statement. That was making a reference to the active worksheet. To make reference to the item in the With statement, you need to use .Cells
I hope this will help.
I would like to delete all empty columns between 2 used ranges, based on the screenshot:
However, these two used ranges may have varying column length, thus the empty columns are not always Columns D to K.
Here is my code:
Sub MyColumns()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Workbooks.Open ("BOOK2.xlsx")
Workbooks("BOOK2.xlsx").Activate
Workbooks("BOOK2.xlsx").Sheets(1).Activate
Workbooks("BOOK2.xlsx").Sheets(1).Cells(1, 4).Value = "NON-EMPTY"
Dim finalfilledcolumn As Long
finalfilledcolumn = Workbooks("BOOK2.xlsx").Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
Dim iCol As Long
Dim i As Long
iCol = firstfilledcolumn + 1
'Loop to delete empty columns
For i = 1 To firstfilledcolumn + 1
Columns(iCol).EntireColumn.Delete
Next i
Workbooks("BOOK2.xlsx").Close SaveChanges:=True
MsgBox "DONE!"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
However, the empty columns still remain.
Do note that the last filled column for the first used range, Place = "USA", Price = "110" and Category = "Mechanical" may not be fixed at Column C, but could go to Column D, E, etc.
Many thanks!
Please, try the next way:
Sub deleteEmptyColumn()
Dim sh As Worksheet, lastCol As Long, rngColDel As Range, i As Long
Set sh = ActiveSheet 'use here your necessary sheet, having the workbook open
'if not open, you can handle this part...
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).column
For i = 1 To lastCol
If WorksheetFunction.CountA(sh.Columns(i)) = 0 Then
If rngColDel Is Nothing Then
Set rngColDel = sh.cells(1, i)
Else
Set rngColDel = Union(rngColDel, sh.cells(1, i))
End If
End If
Next i
If Not rngColDel Is Nothing Then rngColDel.EntireColumn.Delete
End Sub
Try this ..
Dim rng As Range, i As Long
Set rng = Workbooks("BOOK2.xlsx").Sheets(1).UsedRange
For i = rng.Columns.Count To 1 Step -1
If WorksheetFunction.CountA(rng.Columns(i)) = 0 Then
rng.Columns(i).EntireColumn.Delete
End If
Next i
My ultimate goal is to read a range from one workbook and input it into specific cells in another workbook. The source Workbook has a range of autofiltered data in columns A-D. The destination workbook has 8 fields that need to be filled and they will always be the same. For instance, The source workbook will have the first field of the Array MyArray(x) go into the field B2 on the destination workbook. Then MyArray(x) will have x=2 which will populate D2 in the destination workbook from the next visible row in column B. So, it would look like this:
Source workbook
A
B
C
D
1
User Name
AccountNo
Last3
Software to Load
3
User 2
10161_4002
MM1
License E3
4
User 3
10202_2179
118
6
User 5
10141_9863
AA5
License-E3,Reflection
7
User 6
10167_3006
B35
RSI,Java
9
User 8
10176_3393
W45
Office365,Java
And the destination workbook would look like this:
A
B
C
D
1
2
Name:
Account Number:
3
ID:
Software:
4
5
Name:
Account Number:
6
ID:
Software:
So, after running to sub/function, I would have:
[D]=Destination [S]=Source
[D]B2=[S]A3
[D]D2=[S]B3
[D]B3=[S]C3
[D]D3=[S]D3
[D]B5=[S]A4
[D]D5=[S]B4
[D]B6=[S]C4
[D]D6=[S]D4
And so on with 2 rows from the source getting put into the 8 fields of the destination workbook. I have some very basic code at this point but I know this is pretty convoluted. Here is what I've come up with so far which just loops through all of the visible rows and prints out the lines from the range from A2 through the last cell in D with data in it to the immediate window. I've removed it from my main project and just put it all in 2 new workbooks to simplify everything. Ultimately, I'm going to print each page when the destination gets all 8 fields updated and move on to the next page. My code so far:
Sub AddToPrintoutAndPrint()
Dim rng As Range, lastRow As Long
Dim myArray() As Variant, myString() As String
Dim cell As Range, x As Long, y As Long
Dim ws As Worksheet: Set ws = Sheet1 ' Sheet1
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set rng = Range("A2:D" & lastRow)
For Each cell In rng.SpecialCells(xlCellTypeVisible)
ReDim Preserve myArray(x)
myArray(x) = cell.Value
x = x + 1
Next cell
For x = LBound(myArray) To UBound(myArray)
Debug.Print Trim$(myArray(x))
Next x
Set ws = Nothing
End Sub
Thanks for any suggestions
Edit: New block of code to support printing multiple lines
Sub RunIt()
Dim rng As Range
Dim lastRow As Long
Dim ws As Worksheet
Dim coll As Collection
Dim wsDest As Worksheet
Dim rowCounter As Integer
Set ws = Sheets("Sheet1")
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set wsDest = Sheets("Sheet2")
Set rng = Range("A2:A" & lastRow)
Set coll = GetUserInfo(rng.SpecialCells(xlCellTypeVisible))
'This is used to keep a running total of how many rows
'were populated. Since the entries are three rows apart
'we can use the offset function in the loop to choose
'the correct entry. This is also flexible enough
'such that if you ever wanted three or more entries
'per sheet, it will work.
rowCounter = 0
For Each itm In coll
wsDest.Range("B2").Offset(rowCounter * 3).Value = itm(0)
wsDest.Range("D2").Offset(rowCounter * 3).Value = itm(1)
wsDest.Range("B3").Offset(rowCounter * 3).Value = itm(2)
wsDest.Range("D3").Offset(rowCounter * 3).Value = itm(3)
'Increment rowcouter, looping around if you surpass
'two (or any future max number of items)
rowCounter = (rowCounter + 1) Mod 2
'If rowCounter has reset to 0, that means its time to
'print or whatever yuo need to do. Do it below
Debug.Print wsDest.Range("B2").Value
Debug.Print wsDest.Range("B5").Value
Next itm
'Here we check if rowcounter does not equal 0. This indicates
'that the loop ended with an odd number of elements, and should be
'printed out to flush that "buffer"
If rowCounter <> 0 Then
'Do final printout
Debug.Print wsDest.Range("B2").Value
Debug.Print wsDest.Range("B5").Value
End If
End Sub
Function GetUserInfo(rng As Range) As Collection
Dim c As Collection
Dim cel As Range
Dim a(0 To 3)
Set c = New Collection
For Each cel In rng
a(0) = cel.Value
a(1) = cel.Offset(, 1).Value
a(2) = cel.Offset(, 2).Value
a(3) = cel.Offset(, 3).Value
c.Add a
Next cel
'Return the collection
Set GetUserInfo = c
End Function
I'd manage it a bit differently. First, I don't think it's wise to ReDim an array in a loop. I'm not sure how efficiently VBA manages resizing arrays, but it can be an expensive process.
I'd store the relevant values from each row into a collection. The items in the collection will be an array with the relevant fields. This collection can then be looped over, with the data being dropped into the relevant fields (and then printed, or whatever needs to be done).
Let me know if this gets you started.
Sub RunIt()
Dim rng As Range
Dim lastRow As Long
Dim ws As Worksheet
Dim coll As Collection
Dim wsDest As Worksheet
Set ws = Sheets("Sheet1")
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set wsDest = Sheets("Sheet2")
Set rng = Range("A2:A" & lastRow)
Set coll = GetUserInfo(rng)
For Each itm In coll
wsDest.Range("B2").Value = itm(0)
wsDest.Range("D2").Value = itm(1)
wsDest.Range("B3").Value = itm(2)
wsDest.Range("D3").Value = itm(3)
'Maybe do your print routine here, and then reload
Next itm
End Sub
Function GetUserInfo(rng As Range) As Collection
Dim c As Collection
Dim cel As Range
Dim a(0 To 3)
Set c = New Collection
For Each cel In rng
a(0) = cel.Value
a(1) = cel.Offset(, 1).Value
a(2) = cel.Offset(, 2).Value
a(3) = cel.Offset(, 3).Value
c.Add a
Next cel
'Return the collection
Set GetUserInfo = c
End Function
Previously, when I created the worksheets index 1,2,3 in excel,
it can be sorted into like this in index 1 2 and 3 respectively
But now if i stop creating worksheets in excel but through VBA instead, the data cant be populated and it leaves index 1,2 and 3 empty.
This is the code that I used for populating the data but with the addition of add.sheets. The add.sheets here are for creating index1,2,3 worksheets but they doesn't trigger the program to continue to populate the data even though these worksheets exists when I program them in VBA.
Sub UpdateVal()
Static count As Long
Dim iRow As Long
Dim aRow As Long
Dim a As Long
Dim b As Long
Dim selectRange As Range
Dim lastline As Integer
Dim sheetname As String
Dim indexrowcount As Integer
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Result")
Set site_ai = Sheets.Add(after:=Sheets(Worksheets.count))
site_ai.Name = "Index1"
Set site_bi = Sheets.Add(after:=Sheets(Worksheets.count))
site_bi.Name = "Index2"
Set site_ci = Sheets.Add(after:=Sheets(Worksheets.count))
site_ci.Name = "Index3"**
'^additional codes sheets.Add added here for creating worksheets namely index1,2,3
j = 2
iRow = 1
lastline = ws.UsedRange.Rows.count
While iRow < lastline + 1
a = iRow + 1
b = iRow + 17 ' Max Group Size with Same name in F to H column
count = 1
If ws.Cells(iRow, "F").Value = "Martin1" Then
sheetname = "Index1"
ElseIf ws.Cells(iRow, "F").Value = "John1" Then
sheetname = "Index2"
Else
sheetname = "Index3"
End If
For aRow = a To b
If ws.Cells(iRow, "F") = ws.Cells(aRow, "F") And ws.Cells(iRow, "G") = ws.Cells(aRow, "G") And ws.Cells(iRow, "H") = ws.Cells(aRow, "H") Then
count = count + 1
Else
Set selectRange = Range("A" & iRow & ":J" & aRow - 1)
selectRange.Copy
indexrowcount = Sheets(sheetname).UsedRange.Rows.count
Sheets(sheetname).Range("A" & indexrowcount).PasteSpecial xlPasteAll
iRow = iRow + count
Exit For
End If
Next aRow
Wend
End Sub
what am I missing here and how should i solve it?
Your code is too confusing. If your example data is accurate, I don't understand why you need to check all three columns. You can accomplish what you are trying to do, by just using column F. If your data is already sorted as shown, then I would loop through column F testing for duplicates until no match. I would then add a worksheet and name it using the start cells' value. Then copy the rows from the start cell to the current rwNbr - 1 and paste to the new worksheet. Reset the start cell for the next group and loop.
Sub SaveRangewithConsecutiveDuplicateValuestoNewSheet()
'Define all variables
Dim wb As Workbook, ws As Worksheet, sCel As Range, rwNbr As Long
Set wb = ThisWorkbook 'Set workbook variable
Set ws = wb.Worksheets("Sheet1") 'set worksheet variable using workbook variable
Set sCel = ws.Cells(1, 6) 'Set the first start cell variable to test for duplicate values
Application.DisplayAlerts = False
For rwNbr = 2 To ws.Cells(ws.Rows.count, 6).End(xlUp).Offset(1).Row Step 1 'Loop
If ws.Cells(rwNbr, 6).Value <> sCel.Value Then 'loop until the value changes
wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.count)).Name = sCel.Value 'Add sheet and name based on the first cell of group
ws.Range(sCel, ws.Cells(rwNbr - 1, 6)).EntireRow.Copy Destination:=ActiveSheet.Range("A1") 'select group of consecutive duplicates
Set sCel = ws.Cells(rwNbr, 6) 'reset start cell to test for the next group of consecutive duplicates
End If
Next rwNbr
Application.DisplayAlerts = 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