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

Question

I have Sheet1 which contains multiple columns of data. My macro is supposed to grab specific columns from Sheet1, open up Sheet2, and then paste the data into Sheet2 using other logic.

In column A, I have item numbers that range from 1-4, which have the corresponding Item Name in Column B. The top level item will always be 1 (whole product), but depending on the what creates the final product, it can have multiple item number 2, 3, and 4 which are nested underneath each other. For visual purposes:

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

Of course in excel, all the numbers will be aligned in column A and the names will aligned in column B. I'm trying to create a VBA code/logic that when the item number is 1, we copy that item name into column B of the new sheet. If item number is 2, we copy that item name into column C of the new sheet, so on and so forth for 3 and 4. The only tricky part is that if the Item name is different for item numbers 2, 3 or 4, the logic needs to catch that copy/paste the correct names. So my end data would look something like this.

|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 |

My Current VBA Code is below, which doesn't do much but copy and paste the data from sheet1 to 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

` Any help would be appreciated!

Answer 1

Ok, so what I've done here is used a loop to check through every entry in the A column and used some if/elseif statements to determine what values need to be updated. So long as the data is always as you have formatted above I believe this should work.

It updates the appropriate slot of data as it progresses down the list of levels, but upon hitting a number, it'll set every level that comes after it to be NULL . I used NULL because it prints the same as a "" in excel, but it uses less memory.

I've tried to speed it up a bit by doing most of the comparison in memory by taking all the data at once and using arrays. It should be noted, however, you could also make it so that you only perform the print operation once by using a second variant array that you re-dimension as you go, but I've chosen not to here. If there are a large number of items, it is worth considering as continuously accessing the sheet will severely slow down your program.

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

To clarify, this will start looking at the levels from A1 downwards and will paste values into A1:D1 of the second sheet downwards. Please alter the ranges so that it works with your code.