如何根据列或单元格值复制行

Question

我正在尝试使用VBA复制excel中的行并将列合并为一个。

下面的VBA代码隐藏了一些列。我需要帮助编辑我的代码以显示所有列（复制col A到col Q）。

这就是原始数据的样子

这就是我想结束的方式

这就是我使用下面列出的代码的方法（问题：不显示或复制col.B到Col P）

我想显示A和Q之间的所有列。下面的代码隐藏除第一个和合并的列之外的所有列（Col A和col.col上的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