vba to list down changes on sheet3 from sheet1 and sheet2
Question
So I have 2 sheets with different no. of rows due to the changes between the two and I am trying to list them down on sheet3. If they are not on either sheets then I will just place the value as 0 when comparing against the sheets that the identifier is found. I am looping through columns and rows on one sheet and is having problem locating the correct identifier since the no. of rows are different due to the changes, meaning I pull the wrong values from the wrong row.
Dim wb As Workbook
Dim sht1 As Worksheet, sht2 As Worksheet, sht3 As Worksheet
Dim lastrow1 As Integer, lastrow2 As Integer, i As Integer, j As Integer, k As Integer, l As Integer, M As String, rg As Range
Set wb = ThisWorkbook
Set sht1 = wb.Sheets("sheet1")
Set sht2 = wb.Sheets("sheet2")
Set sht3 = wb.Sheets("List of Changes")
lastrow1 = sht1.Cells(rows.Count, "C").End(xlUp).Row
lastrow2 = sht2.Cells(rows.Count, "C").End(xlUp).Row
k = 2
l = 3
sht3.Range("M1:T1") = Array("Seq", "Grade ID", "Item", "UOM", "Issue 1", "Issue 2", "Change", "Remark")
sht3.Range("M1:T1").Font.Bold = True
For j = 8 To 17
For i = 2 To lastrow2
Set rg = sht1.Range("E2:E" & lastrow1).Find(sht2.Range("E" & i))
If rg Is Nothing Then
If sht2.Cells(i, j) = 0 Then
Else
sht3.Range("N" & k).Value = sht2.Cells(i, 5).Value
sht3.Range("O" & k).Value = sht2.Cells(1, j).Value
M = sht3.Range("O" & k).Value
sht3.Range("P" & k).Value = Right(M, 3)
sht3.Range("O" & k).Value = Left(M, 10)
sht3.Range("Q" & k).Value = 0
sht3.Range("R" & k).Value = sht2.Cells(i, j).Value
sht3.Range("S" & k).Value = sht2.Cells(i, j).Value - sht3.Range("Q" & k).Value
k = k + 2
End If
ElseIf sht2.Cells(i, 5) <> sht1.Cells(i, 5) Then
ElseIf sht2.Cells(i, 5) = sht1.Cells(i, 5) Then
If sht2.Cells(i, j) = sht1.Cells(i, j) Then
Else
sht3.Range("N" & k).Value = sht2.Cells(i, 5).Value
sht3.Range("O" & k).Value = sht2.Cells(1, j).Value
M = sht3.Range("O" & k).Value
sht3.Range("P" & k).Value = Right(M, 3)
sht3.Range("O" & k).Value = Left(M, 10)
sht3.Range("Q" & k).Value = sht1.Cells(i, j).Value
sht3.Range("R" & k).Value = sht2.Cells(i, j).Value
sht3.Range("S" & k).Value = sht2.Cells(i, j).Value - sht3.Range("Q" & k).Value
k = k + 2
End If
End If
Next i
Next j
For j = 18 To 27
For i = 2 To lastrow2
Set rg = sht1.Range("E2:E" & lastrow1).Find(sht2.Range("E" & i))
If rg Is Nothing Then
If sht2.Cells(i, j) = 0 Then
Else
sht3.Range("N" & l).Value = sht2.Cells(i, 5).Value
sht3.Range("O" & l).Value = sht2.Cells(1, j).Value
M = sht3.Range("O" & l).Value
sht3.Range("P" & l).Value = Right(M, 2)
sht3.Range("O" & l).Value = Left(M, 10)
sht3.Range("Q" & l).Value = 0
sht3.Range("R" & l).Value = sht2.Cells(i, j).Value
sht3.Range("S" & l).Value = sht2.Cells(i, j).Value - sht3.Range("Q" & l).Value
l = l + 2
End If
ElseIf sht2.Cells(i, 5) <> sht1.Cells(i, 5) Then
ElseIf sht2.Cells(i, 5) = sht1.Cells(i, 5) Then
If sht2.Cells(i, j) = sht1.Cells(i, j) Then
Else
sht3.Range("N" & l).Value = sht2.Cells(i, 5).Value
sht3.Range("O" & l).Value = sht2.Cells(1, j).Value
M = sht3.Range("O" & l).Value
sht3.Range("P" & l).Value = Right(M, 2)
sht3.Range("O" & l).Value = Left(M, 10)
sht3.Range("Q" & l).Value = sht1.Cells(i, j).Value
sht3.Range("R" & l).Value = sht2.Cells(i, j).Value
sht3.Range("S" & l).Value = sht2.Cells(i, j).Value - sht3.Range("Q" & l).Value
l = l + 2
End If
End If
Next i
Next j
End Sub
2 answers
solution1
1 2021-07-12 13:55:15
Consider using a Dictionary Object<\/a> to match the column E values on sheet 2 to the rows on sheet 1. For example
Sub listofchanges()
Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim iLastRow As Long, r1 As Long, r2 As Long, r3 As Long, c As Long
Dim i As Integer, j As Integer
Dim dict As Object, k, key As String, s As String
Set dict = CreateObject("Scripting.Dictionary")
' prepare output sheet
Set wb = ThisWorkbook
Set ws3 = wb.Sheets("List of Changes")
ws3.Cells.Clear
With ws3.Range("M1:T1")
.Value2 = Array("Seq", "Grade ID", "Item", "UOM", _
"Issue 1", "Issue 2", "Change", "Remark")
.Font.Bold = True
End With
' Scan sheet 1
Set ws1 = wb.Sheets("Sheet1")
iLastRow = ws1.Cells(Rows.Count, "E").End(xlUp).Row
' build dictionary from sheet 1 key on column E
For r1 = 2 To iLastRow
key = Trim(ws1.Cells(r1, "E"))
If Len(key) > 0 Then
If dict.exists(key) Then
MsgBox "Duplicate key " & key, vbCritical, ws1.Name & " Row " & r1
Exit Sub
Else
dict.Add key, r1
End If
End If
Next
' Scan sheet 2, compare with sheet 1 and output to sheet 3
Set ws2 = wb.Sheets("Sheet2")
r3 = 1
iLastRow = ws2.Cells(Rows.Count, "E").End(xlUp).Row
For i = 8 To 17
For r2 = 2 To iLastRow
key = Trim(ws2.Cells(r2, "E"))
If Len(key) > 0 Then
' compare with sheet1
If dict.exists(key) Then
r1 = dict(key)
If i = 17 Then dict.Remove key ' last loop
Else
r1 = 0
End If
' col 8,18, 9,19 etc
For j = 0 To 1
c = i + j * 10
s = ws2.Cells(1, c) ' column header
r3 = r3 + 1
With ws3
.Cells(r3, "N") = key
.Cells(r3, "O") = Left(s, 10)
.Cells(r3, "P") = Right(s, 3)
If r1 = 0 Then
.Cells(r3, "Q") = 0
Else
.Cells(r3, "Q") = ws1.Cells(r1, c)
End If
.Cells(r3, "R") = ws2.Cells(r2, c).Value2
.Cells(r3, "S").FormulaR1C1 = "=RC[-1] - RC[-2]" ' Q-R
End With
Next
End If
Next
Next
' add remaining keys from sheet1 not in sheet2
For i = 8 To 27
For Each k In dict.keys
r1 = dict(k)
For j = 0 To 1
c = i + j * 10
s = ws2.Cells(1, c) ' column header
r3 = r3 + 1
With ws3
.Cells(r3, "N") = CStr(k)
.Cells(r3, "O") = Left(s, 10)
.Cells(r3, "P") = Right(s, 3)
.Cells(r3, "Q") = ws1.Cells(r1, c)
.Cells(r3, "R") = 0 ' no sheet 2 value
.Cells(r3, "S").FormulaR1C1 = "=RC[-1] - RC[-2]" ' Q-R
End With
Next
Next
Next
MsgBox "OK", vbInformation
End Sub
solution2
0 ACCPTED 2022-02-06 15:36:49
posting my answer as below
Sub listofchanges()
Dim wb As Workbook
Dim ws1, ws2, ws3 As Worksheet
Dim iLastRow1, iLastRow2, r1, r2, r3, c, x As Long
Dim i, j As Integer
Dim dict As Object, k, key, s As String
Set dict = CreateObject("Scripting.Dictionary")
' prepare output sheet
Set wb = ThisWorkbook
Set ws3 = wb.Sheets("List of Changes")
ws3.Cells.Clear
With ws3.Range("M1:T1")
.Value2 = Array("Seq", "Grade ID", "Item", "UOM", _
"Issue 1", "Issue 2", "Change", "Remark")
.Font.Bold = True
End With
' Scan sheet 1
Set ws1 = wb.Sheets("iss1")
iLastRow1 = ws1.Cells(rows.Count, "E").End(xlUp).Row
' build dictionary from sheet 1 key on column E
For r1 = 2 To iLastRow1
key = Trim(ws1.Cells(r1, "E"))
If Len(key) > 0 Then
If dict.exists(key) Then
MsgBox "Duplicate key " & key, vbCritical, ws1.Name & " Row " & r1
Exit Sub
Else
dict.Add key, r1
End If
End If
Next
' Scan sheet 2, compare with sheet 1 and output to sheet 3
Set ws2 = wb.Sheets("iss2")
r3 = 2
iLastRow2 = ws2.Cells(rows.Count, "E").End(xlUp).Row
For i = 8 To 17
If i = 13 Or i = 15 Or i = 16 Or i = 17 Then
GoTo here1
Else
For r2 = 2 To iLastRow2
key = Trim(ws2.Cells(r2, "E"))
If Len(key) > 0 Then
' compare with iss2
If dict.exists(key) Then
r1 = dict(key)
' If i = 17 Then dict.Remove key ' last loop and remove from dict
Else
r1 = 0
End If
s = ws2.Cells(1, i) ' column header
y = Len(s) - 7 'crop away unwanted words
With ws3
.Cells(r3, "N") = key
.Cells(r3, "O") = Left(s, y)
.Cells(r3, "P") = Right(s, 3)
If r1 = 0 Then
.Cells(r3, "Q") = 0
Else
.Cells(r3, "Q") = ws1.Cells(r1, i) ' this is wrong
End If
.Cells(r3, "R") = ws2.Cells(r2, i).Value2
.Cells(r3, "S").FormulaR1C1 = "=RC[-1] - RC[-2]" ' Q-R
End With
r3 = r3 + 2
End If
Next
End If
here1:
Next
r3 = 3 'MT
For i = 18 To 27
If i = 23 Or i = 25 Or i = 26 Or i = 27 Then
GoTo there1
Else
For r2 = 2 To iLastRow2
key = Trim(ws2.Cells(r2, "E"))
If Len(key) > 0 Then
' compare with iss2
If dict.exists(key) Then
r1 = dict(key)
If i = 24 Then dict.Remove key ' last loop and remove from dict
Else
r1 = 0
End If
s = ws2.Cells(1, i) ' column header
y = Len(s) - 6 'crop away unwanted words
With ws3
.Cells(r3, "N") = key
.Cells(r3, "O") = Left(s, y)
.Cells(r3, "P") = Right(s, 2)
If r1 = 0 Then
.Cells(r3, "Q") = 0
Else
.Cells(r3, "Q") = ws1.Cells(r1, i) 'this is wrong
End If
.Cells(r3, "R") = ws2.Cells(r2, i).Value2
.Cells(r3, "S").FormulaR1C1 = "=RC[-1] - RC[-2]" ' Q-R
End With
r3 = r3 + 2
End If
Next
End If
there1:
Next
r4 = r3 - 2 + 1
r3 = r4
' add remaining keys from iss2 not in iss3
For i = 8 To 17 'k15
If i = 13 Or i = 15 Or i = 16 Or i = 17 Then
GoTo here2
Else
For Each k In dict.keys
r1 = dict(k)
s = ws2.Cells(1, i) ' column header
y = Len(s) - 7 'crop away unwanted words
With ws3
.Cells(r3, "N") = CStr(k)
.Cells(r3, "O") = Left(s, y)
.Cells(r3, "P") = Right(s, 3)
If r1 = 0 Then
.Cells(r3, "Q") = 0
Else
.Cells(r3, "Q") = ws1.Cells(r1, i)
End If
' .Cells(r3, "R") = ws2.Cells(r1, i).Value2
' .Cells(r3, "Q") = ws1.Cells(r1, i)
.Cells(r3, "R") = 0 ' no sheet 2 value bcos not remove from dict, not in iss3
.Cells(r3, "S").FormulaR1C1 = "=RC[-1] - RC[-2]" ' Q-R
End With
r3 = r3 + 2
Next
End If
here2:
Next
r4 = r4 + 1
r3 = r4
For i = 18 To 27 'MT
If i = 23 Or i = 25 Or i = 26 Or i = 27 Then
GoTo there2
Else
For Each k In dict.keys
r1 = dict(k)
s = ws2.Cells(1, i) ' column header
y = Len(s) - 6 'crop away unwanted words
With ws3
.Cells(r3, "N") = CStr(k)
.Cells(r3, "O") = Left(s, y)
.Cells(r3, "P") = Right(s, 2)
If r1 = 0 Then
.Cells(r3, "Q") = 0
Else
.Cells(r3, "Q") = ws1.Cells(r1, i)
End If
' .Cells(r3, "R") = ws2.Cells(r1, i).Value2
' .Cells(r3, "Q") = ws1.Cells(r1, i)
.Cells(r3, "R") = 0 ' no sheet 2 value bcos not remove from dict, not in iss3
.Cells(r3, "S").FormulaR1C1 = "=RC[-1] - RC[-2]" ' Q-R
End With
r3 = r3 + 2
Next
End If
there2:
Next
MsgBox "OK", vbInformation
End Sub
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.
Related Question
Excel vsto add-in sheet1 sheet2 sheet3
How to consolidate Sheet1 and Sheet2 in Sheet3?
I want to paste the rows for the items in Sheet1 Table 1 that are not in Sheet2 Table 2 into Sheet3 with vba
VBA - Compare Sheet1 values to Sheet2, copy/paste the result to Sheet3
How to INDEX from Sheet2 and Sheet3 to find value for Sheet1
How to move first row from Sheet1 to Sheet2, move second row on Sheet1 to Sheet3, move third row on Sheet1 to Sheet4 then repeat?
Copy rows range from Sheet1 to Sheet2 in excel VBA
VBA Vlookup to populate values from sheet1 to sheet2
Extract data from Sheet1 into Sheet2 from a list of data
Excel VBA - Search for value from sheet1 in sheet2 and update with adjacent value from sheet1
Related Tags