excel - VBA 循环遍历范围(如果匹配 : append part of row and specific column header to table in new sheet)

Question

我有一张大约有 12000 行和 200 列的工作表，其构建方式不允许将其用作正确的数据库。前 8 列有我需要的数据，最后 180 列有“地址”标题和“x”表示该列适用的行，“x”可以在一行中出现 1 到 46 次。

源表格式:

我想循环遍历每一行(仅针对最后 180 列)，如果单元格包含“x”，则复制值并附加到新工作表中的表格:

1. 该行的前 8 个单元格

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

3. 如果一行中有超过 1 个“x”，则输出应为每个“x”创建一个新行，其中包含前 8 个单元格的副本以及单元格 9 中的相应标题[编辑:添加3.澄清]

4. 如果一行中没有“x”，则该行可以被忽略。输出表中的下一个可用行应使用下一个具有“x”的源行中的数据进行填充。 [编辑2:添加4.以进行澄清]

结果应如下所示:

我不是 VBA 专家，大多数行只有 1 个“x”，因此我开始使用公式填充第 9 列，其中列标题标有“x”:

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

这为我提供了一行中每个第一个“x”的输出，但这留下了几千行，其中有 2 到 46 倍的“x”。

我尝试开始这样做:

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”添加新行。

我发现了一些有些相似的答案，例如: Loop through rows and columns 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