复制基于单元格值的行，然后添加小计

我对vba相当陌生。 在我决定发表这个问题之前，我做了一些研究，发现了一个类似的解决scheme，但是无法成功地实现代码。 http://www.mrexcel.com/forum/excel-questions/715128-visual-basic-applications-copy-paste-entire-row-second-sheet-based-cell-value.html

我在Microsoft Excel 2010和Windows 7上。基本上，我使用外部软件将原始数据生成到名为“Data”的空白工作簿表单中。 我想复制表格“数据”中的数据并将其呈现在名为“摘要”的表格中。 （我想补充小计）：

使用SQL服务器，我将A列为“1”或“2”。 具有值“1”的行将从工作表“摘要”的第6列C列开始放置。 具有值“2”的行将在具有列标题的第一个数据集小计之后开始两行。 我也想从“摘要”表中排除列A。 我还包括我开始工作的代码。 我明白，我插入的代码是错误的，这就是为什么我发布这个问题：

Sub CopyData() Dim lr As Long, lr2 As Long, r As Long lr = Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row lr2 = Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Row For r = lr To 2 Step -1 If Range("A" & r).Value = "1" Then Rows(r).Copy Destination:=Sheets("Summary").Range("A" & lr2 + 1) lr2 = Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Row End If If Range("A" & r).Value = "2" Then Rows(r).Copy Destination:=Sheets("Sheet1").Range("A" & lr2 + 1) lr3 = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row End If Range("A1").Select Next r End Sub 

我在正确的轨道上？ 有人可以帮忙吗？

Answer 1

或者..一个不同的方法首先sorting数据，用稍短的代码自动检测最后一列

 Sub CopyDatawithSort() Dim sdRow As Long, sdCol As Long Dim ssRow As Long, ssCol As Long 'data start r/c sdRow = 2 sdCol = 1 'summary data start r/c ssRow = 6 ssCol = 1 'last data row and column ldrow = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row ldCol = Sheets("Data").Cells(sdRow, Columns.Count).End(xlToLeft).Column 'sort data in order using column sdcol Sheets("Data").Activate Sheets("Data").Range(Cells(sdRow, sdCol), Cells(ldrow, ldCol)).Select Selection.Sort Key1:=Columns(sdCol), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal 'summary sheet column headers For r = 1 To ldCol Sheets("Summary").Cells(ssRow - 1, r).Value = "Col" & r Next r 'copy data Sheets("Data").Range(Cells(sdRow, sdCol), Cells(ldrow, ldCol)).Copy _ Destination:=Sheets("Summary").Cells(ssRow, ssCol) 'subtotals Sheets("Summary").Activate Sheets("Summary").Cells(ssRow, ssCol).Select Selection.Subtotal GroupBy:=ssCol, Function:=xlSum, TotalList:=Array(2, 3, 4, 5, 6) 'clear Col 1 Sheets("Summary").Columns(ssCol).ClearContents End Sub 

编辑，以达到额外的Q

我不确定您可以使用Excel SubTotal函数删除总计，因此您需要使用代码将其删除。 尝试以下操作：

 Dim lsRow As Long Dim gt As Range 

并将下面的代码片段放在“清除Col 1行”之前

 'remove grandtotal lsRow = Sheets("Summary").Cells(Rows.Count, 1).End(xlUp).Row Set gt = Range(Cells(ssRow, ssCol), Cells(lsRow, ssCol)).Find(After:=Cells(ssRow, ssCol), What:="Grand Total", LookIn:=xlValues, LookAt:=xlWhole, searchorder:=xlByRows) gt.EntireRow.Clear 

Answer 2

macros运行时是否select/激活数据表？ 如果不是，那么无论哪个表是活动的将是数据被复制的工作表。 这一行：

 Rows(r).Copy Destination:=Sheets("Summary").Range("A" & lr2 + 1) 

…从活动工作表复制行“r​​”。 如果你有“摘要”活动，所以你可以看魔术发生，那么你是从“摘要”复制到“摘要”

所以，要么激活“数据”表：

 Sheets("Data").Activate 

或者在行之前明确指定工作表：

 Sheets("Data").Rows(r).Copy Destination:=Sheets("Summary").Range("A" & lr2 + 1) 

编辑：

为了为列A添加分组摘要行，您需要评估每个循环的列A以查看下一个值是否与当前值相同。 如果下一个值不相同，那么你需要插入一个汇总行。 这也需要你有一个计数器，所以你知道有多less行必须被汇总。

所以，你需要包含一行来计算要分组的行。 所以这：

 If Range("A" & r).Value = "1" Then rowCount = rowCount + 1 Sheets("Data").Rows(r).Copy Destination:=Sheets("Summary").Range("A" & lr2 + 1) lr2 = Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Row End If 

并且有一个条件语句在“组”完成时插入汇总行：

 If Range("A" & r).Value <> Range("A" & r - 1).Value Then 'Do a bunch of stuff End If 

“做一堆东西”取决于你想做什么。 也许在A列你什么都不做，B列你总结，C列你平均。 这取决于你的喜好。 例如，虽然：

 Sheets("Summary").Range("A" & r).FormulaR1C1 = "=SUM(R[-" & rowCount & "]C:R[-1]C)" 

这可以变得非常复杂，并且由于您在一张表中添加行，而不是在另一张表中添加行而变得更加复杂。 我build议你玩这个，如果你需要进一步的帮助，提出一个新的问题。 多部分的问题变得混乱的解释。 有很多方法来处理你的问题。

Answer 3

尝试这个。 我不认为你的数据集之间可能有差距来实现Excel小计，你也需要列标题。 如果您愿意，您可以手动插入空行。 我已经定义了一行noCols。 对我来说，如果你只用了几个，就没有意义要拷贝16000多个cols了？ 一旦你开始使用格式化（如果我误解了你的规范！），构造variables是一个好主意。 我将把它留给你来计算如何从你的输出中得到你所需要的总结/总数。 我已经使用了一些额外的VBA语句，您可以研究自己，以带您前进。

 Sub CopyData() Dim lr As Long, lr2 As Long, lr3 As Long Dim oneStartRow As Long Dim startCol As Long Dim noCols As Long Dim rc As Long oneStartRow = 6 startCol = 1 noCols = 33 rc = 0 lr = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row lr2 = Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Row 'headings For r = 1 To noCols Sheets("Summary").Cells(oneStartRow - 1, r).Value = "Col" & r Next r 'dataset 1 For r = 2 To lr If Sheets("Data").Cells(r, 1).Value = "1" Then Sheets("Data").Cells(r, 1).Resize(1, noCols).Copy Sheets("Summary").Cells(oneStartRow + rc, startCol).Select ActiveSheet.Paste rc = rc + 1 End If Next r lr3 = Sheets("Summary").Cells(Rows.Count, 2).End(xlUp).Row rc = 0 'dataset 2 For r = 2 To lr If Sheets("Data").Cells(r, 1).Value = "2" Then Sheets("Data").Cells(r, 1).Resize(1, noCols).Copy Sheets("Summary").Cells(lr3 + rc, startCol).Select ActiveSheet.Paste rc = rc + 1 End If Next r 'subtotals Sheets("Summary").Cells(8, 1).Select 'Anywhere in data to be grouped Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(2, 3, 4, 5, 6) 'Array = Col no's to be summed 'clear col A Sheets("Summary").Columns(1).ClearContents End Sub