Скопируйте данные вставки на основе значения (1, 2 или 3) в столбце A

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, который ничего не делает, но копирует и вставляет данные из листа1 в лист2:

`

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

Хорошо, то, что я здесь сделал, использовал цикл для проверки каждой записи в столбце А и некоторые операторы 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 второго листа вниз.Пожалуйста, измените диапазоны, чтобы он работал с вашим кодом.