问按一定顺序将值从一列复制到另一列。

EN

Option Explicit

Sub FillPack()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source (read (copied) from)
    Dim sws As Worksheet: Set sws = wb.Worksheets("Panels") ' Worksheet
    Dim sfRow As Long: sfRow = 3 ' First Row
    Dim slRow As Long ' Last Row
    slRow = sws.Cells(sws.Rows.Count, "C").End(xlUp).Row
    If slRow < sfRow Then Exit Sub ' no data
    
    ' Destination (written to)
    Dim dws As Worksheet: Set dws = wb.Worksheets("Pack") ' Worksheet
    Dim dfRow As Long: dfRow = 10 ' First Row
    Dim dr As Long: dr = dfRow ' Current Row
    Dim dfCol As Long: dfCol = 1 ' First Column
    Dim dc As Long: dc = dfCol ' Current Column
    Dim dlCol As Long: dlCol = 9 ' Last Column
    Dim dlRow As Long ' Last Row (just to clear the previous data)
    dlRow = dws.Cells(dws.Rows.Count, dfCol).End(xlUp).Row
    If dlRow >= dfRow Then ' Clear previous data
        dws.Range(dws.Cells(dfRow, dfCol), dws.Cells(dlRow, dlCol)).ClearContents
    End If
    
    Dim sr As Long ' Current Row
    
    For sr = sfRow To slRow ' loop through cells of column 'C'
        dws.Cells(dr, dc).Value = sws.Cells(sr, "C").Value ' copy value
        If dc < dlCol Then
            dc = dc + 2 ' every other column
        Else
            dr = dr + 1 ' when all columns are filled then next row...
            dc = dfCol ' ... and start with first column
        End If
    Next sr
        
    MsgBox "Pack filled.", vbInformation
    
End Sub