Getting a pair of numbers sent from one excel sheet to another sheet with gaps in between

Question

For starters, I have data that "usually" comes into 2 rows into excel. I need the (Case #) and (Item #). The problem being is that my (Case #) is on let's say A2 and my (Item #) is on A3 they don't match up perfectly. I also get some (Case #) that have multiple (Item #) which would need to be extracted as well.

I have currently had my VBA code to pull my (Case #) put it does not move down 2 cells for the other (Case #).

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

This is a bit of my code. Here is some Sample data. The data in the middle doesn't matter but does need to be there. Data on the left most column is (Case #) and right most is (Item #)

Answer 1

• Using Find to locate the last row, it may be different with .Cells(.Rows.Count, "A").End(xlUp).Row

Option Explicit
Sub CopyAndPrintData()
    Dim sourceSheet As Worksheet
    Dim destSheet As Worksheet
    Dim lastRowS As Long, lastRowD As Long
    Dim endRow As Long, lastRow As Long
    Dim currentRow As Long, i As Long
    ' 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
    With sourceSheet
        If Application.WorksheetFunction.CountA(.Cells) = 0 Then
            lastRow = 1
        Else
            lastRow = .Cells.Find(What:="*", After:=.Range("A1"), _
            Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, MatchCase:=False).Row
        End If
        lastRowS = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    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
            endRow = 0
            For i = currentRow + 1 To lastRow
                If Len(.Cells(i, 1).Value) > 0 Then
                    endRow = i
                    Exit For
                End If
            Next i
            If endRow = 0 Then endRow = lastRow + 1
            ' Copy data from source sheet to destination sheet
            .Cells(currentRow, 1).Resize(endRow - currentRow).EntireRow.Copy destSheet.Cells(2, 1)
            ' 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.UsedRange.Offset(1).ClearContents
            currentRow = endRow - 1
        Next currentRow
    End With
End Sub