按特定顺序将值从一列复制到另一张表

Question

我试图在 excel 工作表中找到一个代码来创建宏，该代码将从名为“Panels”的工作表和“C”列（从 C3、C4 等开始）复制值并粘贴到名为“Pack”的工作表，但按特定顺序：第一个单元格是A10，然后跳过B10，然后粘贴到C10，跳过D10，粘贴到E10，跳过F10，粘贴到G10，跳过H10，粘贴到I10，跳过J10，然后移动到下一行“11 " 使用相同的跳过和粘贴顺序。

此 excel 工作表的目标是“面板”表包含需要制造的所有项目的列表，“包装”表将包含要运送的相同项目的列表。 然后，操作员将在“已跳过”列中检查标记正确的正在运送的物品。
附件是带有虚构物品示例的“打包”表的屏幕截图。

Answer 1

使用偏移复制和转置

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