VBA，自动筛选并复制大量数据

Question

我在 Excel 工作，我在其中查找名称并通过 VBA 提取与其关联的所有行数据，信息包含在 3 个不同的工作表中并包含不同的信息但是1 单相似，名字。收集数据后，我需要它显示提取数据的 total/average。这是我到目前为止所拥有的，但它需要超过 30 秒并且不允许我添加总计

我已经设置了我的变量并设置了每个工作表

Sub siplifydata()

'Declare values
Dim iphws As Worksheet 
Dim dataws As Worksheet 
Dim ivfnws As Worksheet
Dim ivfpws As Worksheet
Dim agntlg As String
Dim finalrow As Integer 'last row of data

Dim i As Integer 'row counter

'Set values
Set iphws = Sheet1
Set ivfnws = Sheet2
Set ivfpws = Sheet3
Set dataws = Sheet4
agntlg = dataws.Range("F1").Value
    For i = 2 To finalrow
     If Cells(i, 1) = agntlg Then 'Matches login  to name search
     Range(Cells(i, 1), Cells(i, 6)).Copy 'copies columns
     dataws.Select ' go to report sheet
     Range("A50").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 'finds first blank
     iphws.Select ' goes back to continue search
    End If

    Next i
    dataws.Select
    ivfnws.Select

    For i = 2 To finalrow
     If Cells(i, 1) = agntlg Then 'Matches login  to name search
     Range(Cells(i, 1), Cells(i, 6)).Copy 'copies columns
     dataws.Select ' go to report sheet
     Range("H50").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 'finds first blank
     ivfnws.Select ' goes back to continue search
    End If

    Next i
    dataws.Select


    ivfpws.Select

    For i = 2 To finalrow
     If Cells(i, 1) = agntlg Then 'Matches login  to name search
     Range(Cells(i, 1), Cells(i, 6)).Copy 'copies columns
     dataws.Select ' go to report sheet
     Range("O50").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 'finds first blank
     ivfpws.Select ' goes back to continue search
    End If

    Next i
    dataws.Select

Answer 1

分解出公共部分并使用直接赋值而不是复制-激活-粘贴-激活

仅供参考，如果您想在 Excel 中编写可靠的 VBA，您会发现此 post 和相关信息非常有用：

How to avoid using Select in Excel VBA

编辑：已修复并经过测试...

Sub Tester()
    
    Dim agntlg
    '....
    agntlg = "this"
    
    FetchRowsAndSummarize agntlg, iphws, dataws.Range("A50")
    FetchRowsAndSummarize agntlg, ivfnws, dataws.Range("H50")
    FetchRowsAndSummarize agntlg, ivfpws, dataws.Range("O50")
    
    dataws.Select

End Sub

Sub FetchRowsAndSummarize(vSearch, wsSearch As Worksheet, rngDest As Range)
    Const COPY_COLS As Long = 6
    Dim c As Range, cDest As Range, rw As Long, rngCalc As Range, v, colNum As Long
    
    Set cDest = rngDest.End(xlUp).Offset(1, 0) 'start point for copied data
    rw = cDest.Row                             'row of data start point
    For Each c In wsSearch.Range("A2:A" & wsSearch.Cells(Rows.Count, 1).End(xlUp).Row).Cells
        If c.Value = vSearch Then
            cDest.Resize(1, COPY_COLS).Value = c.Resize(1, COPY_COLS).Value
            Set cDest = cDest.Offset(1, 0) 'next row
        End If
    Next c
    
    'insert summary formula(s) - loop over column numbers (of copied data) to summarize
    For Each v In Array(2, 3, 4, 5, 6)
        colNum = cDest.Offset(0, v - 1).Column
        Set rngCalc = wsSearch.Range(wsSearch.Cells(rw, colNum), wsSearch.Cells(cDest.Row - 1, colNum))
        With cDest.Offset(0, v - 1)
            .Formula = "=AVERAGE(" & rngCalc.Address(False, False) & ")"
            .Font.Bold = True
        End With
    Next v
    
End Sub

VBA，自动筛选并复制大量数据

VBA, Auto filter and copy large amount of data

excel

vba

copy

paste