Im currently working on a code that gets a employee number and replace it with their name in the same cell. It works with a loop that go and look for a match in an hiden sheets.
Problem is for some reason i always get a 1004 error from my Find fonction which i coudnt resolve with all of google for some reason : here's my code:
Sub Employe()
Dim ash As Worksheet
Set ash = ActiveSheet
Dim i As Integer
k = 4
no = 0
nom = ""
nos = ""
For i = 1 To 4 'Goes trough the 4 employee nb input
ash.Select
k = k + 1
no = Cells(k, 3).Value 'Gets the employee number value
If no <> "" Then 'look if loop cell is empty
nos = CStr(no)
Sheets("Liste Employé").Select 'select the hidden sheets (not hidden as of right now we'll get to that other problem later)
Dim foundRng As Range
Set foundRng = Range("A2:A91").Find(nos) 'Go look for the matching number in reference sheets range
If foundRng Is Nothing Then
MsgBox ("Entrer un numéro d'employé valide")
Else
nom = CStr(foundRng)
ash.Select
Cells(k, 3).Value = foundRng 'give the value in original sheet
End If
End If
Next
End Sub
The problem is link to this line :
Set foundRng = Range("A2:A91").Find(nos)
Which returns an 1004 error.
I think it has to do with the value of "foundRng" not resetting each loop but no clue how to fix it.
Thx yall, love
There's no need to select a sheet before using Find (so you can safely hide it with no problem)
Set foundRng = Sheets("Liste Employé").Range("A2:A91").Find(what:=nos, lookAt:=xlWhole)
VLookup might be easier:
Sub Employe()
Dim ash As Worksheet, rngInfo As range, res, c As Range
Set ash = ActiveSheet
Dim i As Long
k = 4
Set rngInfo = Sheets("Liste Employé").Range("A2:A91")
For each c in Range("A4:A8").Cells
If c.Value <> "" Then
'lookup the name from ColB
res = application.vlookup(CStr(c.Value), rngInfo, 2, False)
If Not IsError(res) Then
c.Value = res
Else
MsgBox "Entrer un numéro d'employé valide"
End If
End If
Next
End Sub
Im a rather beginner with programming and wanted to ask how I code to pass information from one worksheet to another but only when a condition is met. In my case i have a list of names with their respective jobs. I want to transfer the names to another worksheet but only if the job is X. Since name and surname are in different columns but same row, I also have to find a way of selecting the row in which the job name is.
For Each Candidate In Sheets("XX").Range("A2:A")
If Candidate = "Job" Then
'Copy Name in that same row to Sheets("Job").Range("A" & next free row)
'Copy Surname in that same row to Sheets("Job").Range("B" & next free row)
End If
Next Candidate
Sub transfer_information()
Dim myCell As Range
Dim target As Range
Dim colOffset As Integer
Dim TargetSheetString As String
Dim TargetWorkbookString As String
TargetSheetString = "target worksheet name goes here"
TargetWorkbookString = "target workbook name goes here"
'Uncomment to run with the the active workbook and sheet
'TargetSheetString = ActiveSheet.Name
'TargetWorkbookString = ThisWorkbook.Name
Set target = Workbooks(TargetWorkbookString).Worksheets(TargetSheetString).Range("E2") 'or whatever address
For Each myCell In Range("A1:A100") 'alter 100 as appropriate
colOffset = 2
If myCell.Offset(0, colOffset) = "target job" Then
target = myCell
target.Offset(0, 0) = myCell.Offset(0, 0)
target.Offset(0, 1) = myCell.Offset(0, 1)
target.Offset(0, 2) = myCell.Offset(0, 2)
Set target = target.Offset(1, 0)
End If
Next myCell
End Sub
Assume name is in columns A and B and job in column C
Dim R as Range
dim target as range
set target = Worksheets("target worksheet name goes here").range("a1") 'or whatever address
For each r in RAnge("A1:A100") 'alter 100 as appropriate
if r.offset(0,2) = "target job" then
target = r
target.offset(0,1) = r.offset(0,1)
set target = target.offset(1,0)
end if
next r
I have the following code on a command button that initializes in a Listbox on a Userform and pastes the value into "ThisWorkbook.Worksheets("Sub")".
This only works with one selection, and if you select multiple selections in the Listbox it will only add the first value to cell A8 in column 5.
I want user to be able to pick several options from a listbox. Then, when they save the form, I want the options they selected to populate in the next available row as an Array in the Excel sheet:
Private Sub cmdadd_Click()
On Error Resume Next
Set wks = ThisWorkbook.Worksheets("Sub")
wks.Activate
Dim i As Integer
ActiveSheet.Range("A8").Select
i = 1
Do Until ActiveCell.Value = Empty
ActiveCell.Offset(1, 0).Select 'move down 1 row
i = i + 1 'keep a count of the ID for later use
Loop
'Populate the new data values into the 'Sub' worksheet.
ActiveCell.Value = i 'Next ID number
'Populate the new data values into the 'Sub' worksheet.
ActiveCell.Offset(0, 1).Value = Me.txtls.Text 'set col B
ActiveCell.Offset(0, 2).Value = Me.txtPr.Text
ActiveCell.Offset(0, 3).Value = Me.cbolo.Text
Dim intOffset As Integer
Dim strVal As String
Dim selRange As Range
Set selRange = Selection
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
If strApps = "" Then
strApps = ListBox1.List(i)
intOffset = i
strVal = ActiveCell.Offset(0, 4).Value 'set col E
Else
strApps = strApps & ";" & ListBox1.List(i)
intOffset = i
strVal = strVal & ";" & ActiveCell.Offset(0, 4).Value 'set col E
End If
End If
Next
End Sub
Private Sub UserForm_Initialize()
Me.ListBox1.AddItem "A"
Me.ListBox1.AddItem "3"
Me.ListBox1.AddItem "S"
Me.ListBox1.AddItem "2"
Me.ListBox1.AddItem "S"
End Sub
Avoid Select/Active/Selection/ActiveXXX coding pattern and rely on fully qualified (uop to worksheet, at least) range references
as follows
Option Explicit
Private Sub cmdadd_Click()
Dim wks As Worksheet
Set wks = ThisWorkbook.Worksheets("Sub")
Dim i As Long
With wks.Range("A8") ' reference "sub" worksheet cell A8
i = 1
Do Until .Offset(i - 1).Value = Empty ' check for referenced cell current row offset empty value
i = i + 1 'keep a count of the ID for later use
Loop
'Populate the new data values into the 'Sub' worksheet.
With .Offset(i - 1) ' reference referenced cell row offset to first empty cell
'Populate the new data values into the 'Sub' worksheet.
.Value = i ' set col A with next ID number
.Offset(0, 1).Value = Me.txtls.Text 'set col B
.Offset(0, 2).Value = Me.txtPr.Text 'set col C
.Offset(0, 3).Value = Me.cbolo.Text 'set col D
Dim strApps As String
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) Then strApps = strApps & ListBox1.List(i) & ", " ' update 'strApps' string with listbox selected items separated by a comma and a space
Next
If strApps <> "" Then .Offset(0, 4).Value = Left(strApps, Len(strApps) - 2) ' if any listbox selected values, write 'strApps' in col E
End With
End With
End Sub
I'm trying to delete hidden Names but with a rule that I choose what hidden Name to delete and what not.
Using the code from Microsoft support I managed to make a list of the names
on a log sheet and added a column that when I enter 1 next to it I want to not delete the name, and when I leave it blank U want it to remove the name.
code from Microsoft support (https://support.microsoft.com/en-us/help/119826/macro-to-remove-hidden-names-in-active-workbook)
here is my code:
Sub clean_names()
Application.ScreenUpdating = False
On Error Resume Next
Set nms = ActiveWorkbook.Names
MsgBox (nms.Count)
For R = 1 To nms.Count
Name_Name = nms(R).Name
Name_Referance = nms(R).RefersTo
'###########ActiveWorkbook.Names(Name_Name).Delete
'ActiveWorkbook.nms(R).Delete
Sheets("LOG").Cells(R + 1, 1).Value = Name_Name
Sheets("LOG").Cells(R + 1, 2).Value = "'" + Name_Referance
'Application.StatusBar = R
Next R
'Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
'================================================================
Sub DelNames()
Dim xName As Variant
Dim Indx As Integer
Dim Vis As Variant
Cells(2, 1).Select
If (ActiveCell = "") Then Exit Sub
Indx = 1
Do
If (ActiveCell.Offset(Indx, 2) = "") Then
xName = ActiveCell.Offset(Indx, 0).Value
If xName.Visible = True Then
Vis = "Visible"
Else
Vis = "Hidden"
End If
xName.Delete
End If
Indx = Indx + 1
Loop While Len(ActiveCell.Offset(Indx, 0))
End Sub
How can i make this code work ?
Try the code below, it will loop thorugh all rows in Column A, check if column C is empty, and will delete that Name from your workbook.
Note: I've commented 5 lines from your original code, since according to your post you don't care if the Names are Visible or not, you want to delete them based on the value in Column C.
Code
Option Explicit
Sub DelNames()
Dim xName As Name
Dim Indx As Long
Dim Vis As Variant
Dim LastRow As Long
With Worksheets("LOG")
If IsEmpty(.Range("A2").Value) Then Exit Sub
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row '<-- get last row in column A (where you have a NamedRange)
For Indx = 2 To LastRow
If .Range("C" & Indx).Value = "" Then
' set xName with the text entered in column A (as the Named Range Name)
Set xName = ThisWorkbook.Names(.Range("A" & Indx).Value)
' not sure you need the 5 lines with the If criteria below so I Commented them for now
'If xName.Visible = True Then
' Vis = "Visible"
'Else
' Vis = "Hidden"
'End If
xName.Delete
End If
Next Indx
End With
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