填空

Sub FillBlanks()
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    
    Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet2")
    Dim drg As Range: Set drg = dws.Columns("A:C")
    Dim dcCount As Long: dcCount = drg.Columns.Count
    
    Dim dr As Long: dr = 1
    Dim dc As Long: dc = 1

    Dim sCell As Range
    Dim dCell As Range
    
    For Each sCell In srg.Cells
        If Len(CStr(sCell.Value)) > 0 Then ' the source cell is not blank
            Do
                Set dCell = drg.Cells(dr, dc) ' current destination cell
                
                ' Determine the next destination row and column.
                If dc < dcCount Then dc = dc + 1 Else dc = 1: dr = dr + 1
                
                If Len(CStr(dCell.Value)) = 0 Then ' destination cell is blank
                    sCell.Copy dCell ' copy; more illustrative
                    'dCell.Value = sCell.Value ' write values; more efficient
                    Exit Do
                'Else ' the destination cell is not blank; do nothing
                End If
            Loop
        'Else ' the source cell is blank; do nothing
        End If
    Next sCell

End Sub