根据A列中的值（1、2或3）复制粘贴数据

Question

我有Sheet1，其中包含多列数据。 我的宏应该从Sheet1中获取特定的列，打开Sheet2，然后使用其他逻辑将数据粘贴到Sheet2中。

在A列中，我的项目编号范围是1-4，在B列中具有相应的项目名称。顶层项目始终为1（整个产品），但是根据最终产品的创建方式，它可以有多个编号为2、3和4的项目，它们相互嵌套。 出于视觉目的：

1 Phone 2 Battery 3 Lithium 3 LithiumX 2 Camera 3 Glass 4 Bulb 4 Lens

当然在excel中，所有数字都将在A列中对齐，名称将在B列中对齐。我正在尝试创建一个VBA代码/逻辑，当项目编号为1时，我们将该项目名称复制到B列中新工作表。 如果项目编号为2，则将该项目名称复制到新工作表的C列中，依此类推，以此类推，直到3和4。唯一棘手的部分是，如果项目编号2、3或4的项目名称不同。逻辑需要捕获该副本/粘贴正确的名称。 所以我的最终数据看起来像这样。

|A| B | C | D | E | |1|Phone| | | |2|Phone| Battery | | |4|Phone| Battery | Lithium | |5|Phone| Battery | LithiumX| |6|Phone| Battery | LithiumX| |7|Phone| Camera | | |8|Phone| Camera | Glass | |9|Phone| Camera | Glass | Bulb |

下面是我当前的VBA代码，它没有做很多事情，但是将数据从sheet1复制并粘贴到sheet2：

`

cls = Array("A1", "B1")

Set sh1 = Sheets("Sheet1")
'Set sh2 = ThisWorkbook.Sheets(2)
Set sh2 = Worksheets.Add(Type:=xlWorksheet, After:=Application.ActiveSheet)
On Error Resume Next
sh2.Name = "Test"
On Error GoTo 0

'Clear sheet 2
sh2.Cells.Clear

'cut specific headers from Sheet 1 and paste to sheet 2
With sh2
    LR = WorksheetFunction.Max(1, .Range("A" & Rows.Count).End(xlUp).Row)
    For n = LBound(cls) To UBound(cls)
        Me.Range(cls(n)).Copy Destination:=.Cells(LR, n + 1)
    Next n
End With

Let lrow1 = sh1.Range("A65356").End(xlUp).Row

For i = 2 To lrow1
    Let lrow3 = sh2.Range("A65356").End(xlUp).Row
        sh2.Cells(lrow3 + 1, 1) = sh1.Cells(i, 1)
        sh2.Cells(lrow3 + 1, 2) = sh1.Cells(i, 2)

Next i

`任何帮助将不胜感激！

Answer 1

好的，所以我在这里所做的工作是使用循环检查A列中的每个条目，并使用一些if/elseif语句来确定需要更新哪些值。 只要数据始终如您所格式化，我相信这应该可以工作。

它随着在级别列表中向下移动而更新适当的数据插槽，但是一旦击中一个数字，它将把其后的每个级别设置为NULL 。 我使用NULL是因为它在excel中的输出与“”相同，但它使用的内存更少。

我试图通过一次获取所有数据并使用数组来进行内存中的大多数比较，从而加快了速度。 应该注意的是，但是，您也可以使用第二个变量数组来执行一次打印操作，该数组在您进行操作时会重新定义维数，但是我在这里选择了不做。 如果有大量项目，则值得考虑，因为连续访问工作表将严重降低程序速度。

Option Explicit

Sub CascadingList()
    Dim Levels(1 To 4) As String
    Dim Subcount As Long
    Dim cell As Variant
    Dim Lastrow As Long
    Dim Data() As Variant

    Lastrow = ActiveSheet.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    Data = ActiveSheet.Range("A1:B" & Lastrow).Value
    Subcount = 1

    For cell = 1 To UBound(Data, 1)
        If Data(cell, 1) = 1 Then
            Levels(1) = Data(cell, 2)
            Levels(2) = vbNullString
            Levels(3) = vbNullString
            Levels(4) = vbNullString
        ElseIf Data(cell, 1) = 2 Then
            Levels(2) = Data(cell, 2)
            Levels(3) = vbNullString
            Levels(4) = vbNullString
        ElseIf Data(cell, 1) = 3 Then
            Levels(3) = Data(cell, 2)
            Levels(4) = vbNullString
        ElseIf Data(cell, 1) = 4 Then
            Levels(4) = Data(cell, 2)
        End If
        ActiveWorkbook.Worksheets(2).Range("A" & Subcount & ":D" & Subcount).Value = Levels
        Subcount = Subcount + 1
    Next cell
End Sub

为了清楚起见，这将开始从A1向下看，并将值向下粘贴到第二张纸的A1:D1中。 请更改范围，使其与您的代码一起使用。