'vba to list down changes on sheet3 from sheet1 and sheet2

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.

This is what I have wrote so far, not sure if anyone can give a hand.

this is just column and row loop


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

This one loops to sheet2 as well with 3 loops

Sub listofchangesfail()

Dim wb As Workbook
Dim sht1 As Worksheet, sht2 As Worksheet, sht3 As Worksheet
Dim lastrow1 As Integer, lastrow2, lastrow3, lastrow4 As Integer, h, x, 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
        For h = 2 To lastrow1
    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(h, 5) Then
            
            ElseIf sht2.Cells(i, 5) = sht1.Cells(h, 5) Then
                If sht2.Cells(i, j) = sht1.Cells(h, 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(h, 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 h
    Next i
Next j
                    
For j = 18 To 27
    For i = 2 To lastrow2
        For h = 2 To lastrow1
    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(h, 5) Then
            
            ElseIf sht2.Cells(i, 5) = sht1.Cells(h, 5) Then
                If sht2.Cells(i, j) = sht1.Cells(h, 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(h, 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 h
    Next i
Next j


End Sub

excel vba loops

Solution 1:^[1]

Consider using a Dictionary Object 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

Sources

This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.

Source: Stack Overflow

Solution	Source
Solution 1	CDP1802

'vba to list down changes on sheet3 from sheet1 and sheet2

Solution 1:[1]

Sources

Related Questions

Solution 1:^[1]