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

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 服务器，我将 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

并将以下代码段放在'clear 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