VBA遍历范围（如果匹配）：将行的一部分和特定的列标题附加到新表中的表中

Question

我有一个工作表，其中包含大约12000行和200列，其工作方式不允许将其用作适当的数据库。前8列具有我需要的数据，后180列具有“地址”标题，并且该列适用的行带有“ x”，“ x”可以出现在1到46次之间。

源表格式：

我想遍历每一行（仅适用于最后180列），如果单元格包含“ x”，则复制值并将其追加到新表中的表中：

1. 该行的前8个单元格

2. 标有“ x”的列的标题，标题变为单元格9

3. 如果一行中有多个“ x”，则输出应为每个“ x”都换行，并带有前8个单元格的副本和单元格9中相应的标题[编辑：添加3。

4. 如果一行中没有“ x”，则可以忽略该行。输出表中的下一个可用行应填充来自确实具有“ x”的下一个源行的数据。[编辑2：增加了4.以供澄清]

结果应如下所示：

我不是VBA专家，大多数行都只有1个“ x”，因此我首先使用公式用“ x”标记的列标题填充第9列：

=INDEX(R3C13:R3C192, SUMPRODUCT(MAX((RC[-184]:RC[-5]=R2C198)*(COLUMN(RC[-184]:RC[-5]))))-COLUMN(R[-1]C[-184])+1)

这给了我一行上每一个 “ x”的输出，但是留下了几千行，其中“ x”是2到46倍。

我尝试使用以下方法入门：

Sub Test()
Dim rw As Long, Cell As Range
For Each Cell In Sheets("1").Range("K:R")
rw = Cell.Row
 If Cell.Value = "x" Then
  Cell.EntireRow.Copy
   Sheets("2").Range("A" & rw).PasteSpecial xlPasteValues
 End If
Next
End Sub

显然，这是一个很粗糙的开始，并没有给我：

1. 只需复制该行的前8个单元格

2. 将“ x”列的标题复制到单元格9（对于右行）

3. 它还不会在新表的底部为每个“ x”添加新行。

我找到了一些类似的答案，例如： 遍历行和列Excel Macro VBA

但是无法针对我的情况进行这项工作。任何帮助将不胜感激，谢谢！

Answer 1

尝试此代码，这会将前 8 个单元格设置为仅包含“x”的行。

Sub appendit()
Dim i, j, lrow, lcol As Long
Dim rCount, cCount As Long
 Dim addressString As String
Dim wb As Workbook
Dim ws As Worksheet
Dim newWs As Worksheet
Dim vMain As Variant




Set wb = ActiveWorkbook 'or whatever your workbook is
Set ws = wb.Sheets(1) 'or whatever your sheet is
wb.Sheets.Add(before:=wb.Sheets(1)).Name = "Output"
Set newWs = wb.Sheets("Output")
rCount = 1
With ws
lrow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Load the data into an array for efficiency
lcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
ReDim vMain(1 To lrow, 1 To lcol)
For i = 1 To lrow
    For j = 1 To lcol
        vMain(i, j) = .Cells(i, j)
    Next j
Next i
End With
With newWs
For i = 21 To UBound(vMain, 2) 'starting from the 21st column as the first 20 are not to be included.
    For j = 1 To UBound(vMain, 1)
        If vMain(j, i) = "x" Then
            .Cells(rCount, 1) = vMain(j, 1)
            .Cells(rCount, 2) = vMain(j, 2)
            .Cells(rCount, 3) = vMain(j, 3)
            .Cells(rCount, 4) = vMain(j, 4)
            .Cells(rCount, 5) = vMain(j, 5)
            .Cells(rCount, 6) = vMain(j, 6)
            .Cells(rCount, 7) = vMain(j, 7)
            .Cells(rCount, 8) = vMain(j, 8)
            .Cells(rCount, 9) = vMain(1, i)
            rCount = rCount + 1   
    End If
    Next j
Next i
End With
End Sub