Как дублировать строку на основе значения столбца или ячейки

Question

Я пытаюсь дублировать строки в excel с помощью VBA и объединять столбцы в один.

Код VBA ниже скрывает некоторые столбцы. Мне нужна помощь в редактировании моего кода, чтобы показать все столбцы (скопировать col A через col Q).

Это как исходные данные выглядит

Это, как я хотел бы закончить до

Это, как я получить, используя код, приведенный ниже (проблема: оленья кожа шоу или копия цв. B до Col P)

I woul d хотел бы показать все столбцы между A и Q. Кодекс ниже скрывает все столбцы, кроме первого и объединенного (Col A и объединенный col на col. Б).

Sub SortMacro() 
    Dim SourceSheet As Worksheet 
    Dim OutSheet As Worksheet 

    Set SourceSheet = ActiveSheet 
    Set OutSheet = Sheets.Add 

With SourceSheet 
    Out_i = 1 
    For r = 1 To .Cells(Rows.Count, 1).End(xlUp).Row 
    For i = 17 To 20 'or For each i in Array(17,18,20) 
     OutSheet.Cells(Out_i, 1) = .Cells(r, 1) 
     OutSheet.Cells(Out_i, 2) = .Cells(r, i) 
     Out_i = Out_i + 1 
    Next 
    Next 
End With 
End Sub 

Спасибо!

Answer 1

Это моя интерпретация того, что вам нужно. Я добавил цикл для копирования столбцов A: P в каждую новую строку

Sub SortMacro() 

Dim SourceSheet As Worksheet 
Dim OutSheet As Worksheet 

Set SourceSheet = ActiveSheet 
Set OutSheet = Sheets.Add 

With SourceSheet 
    Out_i = 1 
    For r = 1 To .Cells(Rows.Count, 1).End(xlUp).Row 
    ' Create a new row for each column entry in Q:T 
    For i = 17 To 20 
     ' Check the cell isn't empty before creating a new row 
     If (.Cells(r, i).Value <> "") Then 
     ' Copy columns A:P 
     For j = 1 To 16 
      OutSheet.Cells(Out_i, j) = .Cells(r, j) 
     Next j 

     ' Copy the current column from Q:T 
     OutSheet.Cells(Out_i, 17) = .Cells(r, i) 
     Out_i = Out_i + 1 
     End If 
    Next i 
    Next r 
End With 

End Sub