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中。请更改范围，使其与您的代码配合使用。

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

1 个答案: