如何解决VBA,自动过滤和复制大量数据
我在 Excel 中工作,我在其中查找名称并通过 VBA 提取与它们关联的所有行数据,信息包含在 3 个不同的工作表中,包含不同的信息,但只有 1 个相似性,即名称。收集数据后,我需要它显示提取数据的总数/平均值。到目前为止,这是我所拥有的,但需要超过 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,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,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
解决方法
分解公共部分并使用直接赋值代替复制-激活-粘贴-激活
仅供参考,如果您想在 Excel 中编写强大的 VBA,您会发现这篇文章和相关信息非常有用:
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
版权声明:本文内容由互联网用户自发贡献,该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 dio@foxmail.com 举报,一经查实,本站将立刻删除。