时间戳

首页 > 解决方案 > vba 从 sheet1 和 sheet2 列出 sheet3 上的更改

excel - vba 从 sheet1 和 sheet2 列出 sheet3 上的更改

问题描述

所以我有两张不同的床单。由于两者之间的变化而导致的行数，我试图在 sheet3 上列出它们。如果它们不在任何一张纸上，那么在与找到标识符的工作表进行比较时，我只会将该值设置为 0。我正在遍历一张纸上的列和行，并且由于没有找到正确的标识符而遇到问题。由于更改，行数不同，这意味着我从错误的行中提取了错误的值。

这是我目前写的，不知道有没有人可以帮忙。

这只是列和行循环


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

这一个循环到 sheet2 以及 3 个循环

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

标签： excelvbaloops

解决方案

考虑使用字典对象将工作表 2 上的 E 列值与工作表 1 上的行匹配。例如

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

推荐阅读