[英]VBA to loop through range, if match: append part of row and specific column header to table in new sheet
I have a sheet with roughly 12000 rows and 200 columns built up in a way that doesn't allow using it as a proper database. 我有一个大约12000行和200列的表单,其构建方式不允许将其用作正确的数据库。 The first 8 columns have data I need, the last 180 columns have "address" headers and an "x" for rows where the column applies, "x" can appear in a row between 1 and 46 times.
前8列有我需要的数据,最后180列有“地址”标题,而列适用的行有“x”,“x”可以出现1到46次之间的行。
Source table format: 源表格式:
I want to loop through each row (only for the last 180 columns) and if a cell contains an "x" then copy values and append to a table in a new sheet: 我想循环遍历每一行(仅适用于最后180列),如果单元格包含“x”,则复制值并附加到新工作表中的表:
the first 8 cells from that row 该行的前8个单元格
the header of the column marked by the "x", the header becomes cell 9 标题为“x”的列的标题,标题变为单元格9
if there is more than 1 "x" in a row, output should have a new line for every "x" with the a copy of the first 8 cells and the corresponding header in cell 9 [edit: added 3. for clarification] 如果一行中有超过1个“x”,则输出应该为每个“x”添加一个新行,其中前8个单元格的副本和单元格9中的相应标题[编辑:添加3.以便澄清]
if there is no "x" in a row, that row can be ignored. 如果一行中没有“x”,则可以忽略该行。 The next available row in the output table should be populated with the data from the next source row that does have an "x".
应使用来自具有“x”的下一个源行的数据填充输出表中的下一个可用行。 [edit 2: added 4. for clarification]
[编辑2:添加4.澄清]
Result should look something like this: 结果应如下所示:
I'm no VBA expert and most rows just have 1 "x" so I started with using a formula to populate column 9 with the header of the column marked by "x": 我不是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)
This gives me output for every first "x" on a row, but that leaves a couple of thousand rows with between 2 and 46 times "x". 这给了我一行中每个第一个 “x”的输出,但是留下了几千行,其中“x”是2到46倍。
I tried getting started on this with: 我试着开始这个:
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
Obviously this is a pretty rough start and does not give me: 显然这是一个非常艰难的开始并没有给我:
just copy the first 8 cells of the row 只需复制该行的前8个单元格
copy the header of the "x" column to cell 9 (for the right row) 将“x”列的标题复制到单元格9(对于右侧行)
It also does not append a new line for each "x" at the bottom of my new table. 它也不会为我新表底部的每个“x”附加一个新行。
I found some answers that are somewhat similar, such as: Loop through rows and columns Excel Macro VBA 我找到了一些有点类似的答案,例如: 循环遍历行和列Excel宏VBA
But have not been able to make this work for my scenario. 但是无法为我的场景做这项工作。 Any help would be much appreciated, thanks!
任何帮助将不胜感激,谢谢!
Try this code, this sets the first 8 cells to only the rows that contain "x". 尝试此代码,这会将前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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.