根据单元格值复制行，然后添加小计

Question

我对 vba 很陌生。在我决定发布这个问题之前，我做了一些研究并找到了类似的解决方案，但无法成功实现代码。 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。基本上，我使用外部软件将原始数据生成到名为“数据”的空白工作簿表中。我想从工作表“数据”中复制数据并将其呈现在一个名为“摘要”的工作表中。 （我想添加小计）：

使用 SQL Server，我将 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

或者 .. 一种不同的方法 首先对数据进行排序，然后使用略短的代码自动检测最后一列

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

并将以下代码 sn-p 放在'clear Col 1 line 之前

'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

当宏运行时，您的数据表是否被选中/激活？如果不是，那么任何处于活动状态的工作表都将是从中复制数据的工作表。这一行：

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 列，以查看下一个值是否与当前值相同。如果下一个值不同，则需要插入摘要行。这还要求您有一个计数器，以便知道必须汇总多少行。

因此，您需要添加一行来计算要分组的行数。所以这个：

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)" 

这可能会变得非常复杂，并且由于您在一张纸上添加行而不是在另一张纸中添加行，因此变得更加复杂。我建议你玩这个，如果你需要进一步的帮助，提出一个新问题。多部分问题难以解释。并且有很多很多方法可以解决您的问题。

Answer 3

试试这个。 我认为您的数据集之间不能有差距来实现 Excel 小计，而且您还需要列标题。如果您愿意，可以手动插入空白行。 我已将一行定义为 noCols。对我来说，如果你只使用几个，复制超过 16,000 列没有意义吗？ 构建你的变量是一个好主意，一旦你开始（如果我误读了你的规范！），在格式化方面给你更多的灵活性。 我将留给您计算如何从您拥有的输出中获取您在 col H 中所需的任何摘要/总数！ 我使用了一些额外的 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