将一对数字从一张Excel表格发送到另一张表格，中间有间隙

Question

对于初学者来说，我的数据“通常”在 Excel 中分为 2 行。我需要（案例#）和（项目#）。问题是我的（案例#）在 A2 上，而我的（项目#）在 A3 上，它们并不完美匹配。我还得到了一些（案例#），其中有多个（项目#）也需要提取。

我目前有 VBA 代码来拉动我的（案例#），但它不会为另一个（案例#）向下移动 2 个单元格。

Sub CopyAndPrintData()
    Dim sourceSheet As Worksheet
    Dim destSheet As Worksheet
    Dim lastRow As Long
    Dim currentRow As Long
    
    ' Set the source and destination sheets
    Set sourceSheet = ThisWorkbook.Sheets("DATA") sheet

    Set destSheet = ThisWorkbook.Sheets("LOTTAG") 

    ' Find the last row with data in the source sheet
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
    
    ' Loop through each row in the source sheet
    For currentRow = 2 To lastRow ' Assuming your data starts from row 2, change as needed
        ' Copy data from source sheet to destination sheet
        sourceSheet.Rows(currentRow).Copy destSheet.Rows(currentRow)
        
        ' Print the destination sheet
        destSheet.PrintOut
        
        'Pause for a moment 
        Application.Wait Now + TimeValue("00:00:02") ' Wait for 2 seconds
        
        ' Clear contents of the destination sheet for the next iteration
        destSheet.Rows(currentRow).ClearContents
    Next currentRow
End Sub

这是我的一些代码。 这是一些示例数据。中间的数据并不重要，但确实需要存在。最左边一列的数据是（案例编号），最右边的数据是（项目编号） [1]：

Answer 1

• 使用Dictionary对象追踪案例#
• 添加

  for

  循环来定位相同的案例#

Option Explicit
Sub CopyAndPrintData()
    Dim sourceSheet As Worksheet
    Dim destSheet As Worksheet, sKey as String
    Dim lastRowS As Long, lastRowD As Long
    Dim currentRow As Long, oDic As Object, i As Long
    Set oDic = CreateObject("scripting.dictionary")
    ' Set the source and destination sheets
    Set sourceSheet = ThisWorkbook.Sheets("DATA")
    Set destSheet = ThisWorkbook.Sheets("LOTTAG")
    ' Find the last row with data in the source sheet
    lastRowS = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
    lastRowD = destSheet.Cells(destSheet.Rows.Count, "A").End(xlUp).Row
    If lastRowD > 1 Then
        destSheet.Rows("2:" & lastRowD).ClearContents
    End If
    ' Loop through each row in the source sheet
    With sourceSheet
        For currentRow = 2 To lastRowS ' Assuming your data starts from row 2, change as needed
            lastRowD = 1
            sKey = .Cells(currentRow, 1).Value
            If Not oDic.exists(sKey) Then
                ' Copy data from source sheet to destination sheet
                lastRowD = lastRowD + 1
                .Rows(currentRow).Copy destSheet.Rows(lastRowD)
                oDic(sKey) = ""
                ' Looking for same case#
                For i = currentRow + 1 To lastRowS
                    If sKey = .Cells(i, 1).Value Then
                        lastRowD = lastRowD + 1
                        .Rows(i).Copy destSheet.Rows(lastRowD)
                    End If
                Next i
                ' Print the destination sheet
                destSheet.PrintOut
                'Pause for a moment
                Application.Wait Now + TimeValue("00:00:02") ' Wait for 2 seconds
                ' Clear contents of the destination sheet for the next iteration
                destSheet.Rows("2:" & lastRowD).ClearContents
            End If
        Next currentRow
    End With
End Sub