Excel宏帮助过滤多个工作簿中的数据并将其复制到不同的工作表中

Question

我需要一些帮助(可能会有很多帮助(来编写一个宏，该宏将执行以下操作-

在主工作簿中，用户将选择选项->A、 B或C，然后单击运行宏按钮。宏将执行以下操作-

->select sheet100 in master workbook
-> select files to open (all available in single folder, arranged by name)
-> Loop starts
-> open target file (has to start from 1st file by name in the folder)
-> search target file first row for value "Dimension"
-> If Option A was selected set auto filter on Dimension with filters "One" and "two"
-> If Option B was selected set auto filter on Dimension with filters "three" and " and "four"
-> If Option C was selected set auto filter on Dimension with filters "five" and " and "six"
-> copy all filtered data
-> paste special values starting from cell A6 of sheet100 (which was activated above before loop started) in master workbook
-> goes to next sheet of master file
-> If there is a second worksheet, go to that worksheet
->  use the same logic to filter and copy data to master workbook's next sheet

-> loops till the last worksheet in the last target workbook

我有一些零碎的代码，比如将下拉列表中选择的值转换为字符串，激活sheet100，打开文件夹中的文件，并为所有选定的目标文件运行循环，但无法完成整个代码。

如有任何帮助，我们将不胜感激。

Answer 1

复制筛选列表时使用SpecialCells(xlCellTypeVisible)。我已将具有筛选范围的页眉复制到目标工作表，然后删除了页眉。这避免了处理空列表的复杂性。

更新-删除了自动工作表创建，并添加了检查是否有工作表可以放置数据。复制所有数据(带标题(，而不仅仅是筛选列。

更新2-使用Sheet100到Sheet118作为工作表代码名称。

更新3-对所有列应用筛选器，仅粘贴特殊值。你可以做一些事情来加快代码的速度

Option Explicit
Sub Macro1()
Const FIRST_SHEET = 100
Const LAST_SHEET = 118
Const TARGET_ROWNO = 1 '
Const TARGET_COLNO = 7 ' G
Const FILTER_COL = "Vertical"
Dim wbData As Workbook, wbMaster As Workbook
Dim ws As Worksheet, wsData As Worksheet, wsMaster As Worksheet
Dim sFolder As String, sFile As String, sOption As String
Dim rng As Variant, colno As Integer, iLastRow As Long, iLastCol As Integer
Dim crit As Variant, n As Long
Dim OFLastCol As Long, OFLastRow As Long
Dim dict As Object, sCodeName As String
Set dict = CreateObject("Scripting.Dictionary")
sOption = Sheet52.Range("H8").Value 'capturing selected vertical
Select Case UCase(sOption) 'setting the filter values
Case "INSURANCE": crit = Array("INSURANCE")
Case "BFS": crit = Array("BFS")
Case "PNR": crit = Array("RETAIL", "MLEU", "T&H")
Case "FSI GGM": crit = Array("INSURANCE", "BFS")
Case Else
MsgBox "No option selected", vbCritical
Exit Sub
End Select
' select folder
Application.StatusBar = "Please be select folder to scan..."
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.InitialFileName = sFolder
.Show
sFolder = .SelectedItems(1)
End With
sFile = Dir(sFolder & "*.xls*")
Set wbMaster = ThisWorkbook
' clear data sheets
' and map code names to index
For Each ws In wbMaster.Sheets
sCodeName = ws.CodeName 'Sheet100 to sheet118
dict(sCodeName) = ws.Index ' codename to index
' clear old data
n = Mid(sCodeName, 6)
If n >= FIRST_SHEET And n <= LAST_SHEET Then
Set rng = ws.UsedRange
iLastCol = rng.Column + rng.Columns.Count - 1
iLastRow = rng.Row + rng.Rows.Count - 1
If iLastCol >= TARGET_COLNO Then
Set rng = ws.Range(ws.Cells(TARGET_ROWNO, TARGET_COLNO), ws.Cells(iLastRow, iLastCol))
rng.Cells.ClearContents
'Debug.Print "Cleared", n, rng.Address
End If
End If
Next
' scan files
n = 100
Do While Len(sFile) > 0
Set wbData = Workbooks.Open(sFolder & "" & sFile, ReadOnly:=True) ' updatelink, readonly
' open each sheet in turn
For Each wsData In wbData.Sheets
' find the filter column in row 1
Set rng = wsData.Rows(1).Find(FILTER_COL, LookIn:=xlValues, LookAt:=xlWhole)
If Not rng Is Nothing Then
colno = rng.Column
' last row of filter column
OFLastRow = wsData.Cells(Rows.Count, colno).End(xlUp).Row
If OFLastRow > 1 Then
' range to apply filter to
OFLastCol = wsData.Cells(1, Columns.Count).End(xlToLeft).Column ' move left

Set rng = wsData.Range("A1", wsData.Cells(OFLastRow, OFLastCol))
rng.AutoFilter Field:=colno, Criteria1:=crit, Operator:=xlFilterValues
' range to copy
Set rng = rng.SpecialCells(xlCellTypeVisible)
' is there data to copy
If rng.Rows.Count > 1 Or rng.Areas.Count > 1 Then
' check sheet available
sCodeName = "Sheet" & n
If dict.exists(sCodeName) Then
Set wsMaster = wbMaster.Sheets(dict(sCodeName))
Else
MsgBox sCodeName & " not found", vbCritical
Exit Sub
End If
' copy / paste all columns of visible rows
rng.Copy
With wsMaster.Cells(TARGET_ROWNO, TARGET_COLNO)
.PasteSpecial Paste:=xlPasteValues
End With
Application.CutCopyMode = False
wsMaster.Activate
wsMaster.Range("A1").Select
Else
MsgBox "No data after filter on sheet " & wsData.Name, vbExclamation, wbData.Name
End If
Else
MsgBox "No data in column " & colno & " on sheet " & wsData.Name, vbExclamation, wbData.Name
End If
Else
MsgBox FILTER_COL & " not found on sheet " & wsData.Name, vbExclamation, wbData.Name
End If
n = n + 1 ' next data sheet
Next
wbData.Close False
sFile = Dir() ' next file in folder
Loop
MsgBox sFolder & " files scanned for option " & sOption, vbInformation
End Sub

Answer 2

@CDP1802：更新2-由于过滤器在第一张纸上失败，我所做的修改代码。我没有选择1列，而是选择了整个范围，并使用colno变量进行过滤。

这完全有效，但花了大量时间(近10分钟(将8200行数据粘贴到第一张表的90行(总共花了1个小时(。我还添加了Paste:=xlPasteValues参数以加倍确定，但这仍然需要很长时间。对于数据量较低的纸张，它以更好的速度通过。知道为什么会发生这种事吗？

此外，您可以更改代码中的筛选器逻辑吗？我将把它标记为已接受的答案。

Sub test()
Const FIRST_SHEET = 100
Const LAST_SHEET = 118
Const TARGET_ROWNO = 1 '
Const TARGET_COLNO = 7 ' G
Const FILTER_COL = "Vertical"
Dim OFLastCol As Long
Dim OFLastRow As Long

Dim wbData As Workbook, wbMaster As Workbook
Dim ws As Worksheet, wsData As Worksheet, wsMaster As Worksheet
Dim sFolder As String, sFile As String, sOption As String
Dim rng As Variant, colno As Integer, iLastRow As Long, iLastCol As Integer
Dim crit As Variant, n As Long
Dim dict As Object, sCodeName As String
Set dict = CreateObject("Scripting.Dictionary")
sOption = Sheet52.Range("H8").Value 'capturing selected vertical
Select Case UCase(sOption) 'setting the filter values
Case "INSURANCE": crit = Array("INSURANCE")
Case "BFS": crit = Array("BFS")
Case "PNR": crit = Array("RETAIL", "MLEU", "T&H")
Case "FSI GGM": crit = Array("INSURANCE", "BFS")
Case Else
MsgBox "No option selected", vbCritical
Exit Sub
End Select
' select folder
Application.StatusBar = "Please be select folder to scan..."
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.InitialFileName = sFolder
.Show
sFolder = .SelectedItems(1)
End With
sFile = Dir(sFolder & "*.xls*")
Set wbMaster = ThisWorkbook
' clear data sheets
' and map code names to index
For Each ws In wbMaster.Sheets
sCodeName = ws.CodeName 'Sheet100 to sheet118
dict(sCodeName) = ws.Index ' codename to index

' clear old data
n = Mid(sCodeName, 6)
If n >= FIRST_SHEET And n <= LAST_SHEET Then

Set rng = ws.UsedRange
iLastCol = rng.Column + rng.Columns.Count - 1
iLastRow = rng.Row + rng.Rows.Count - 1
If iLastCol >= TARGET_COLNO Then
Set rng = ws.Range(ws.Cells(TARGET_ROWNO, TARGET_COLNO), ws.Cells(iLastRow, iLastCol))
rng.Cells.ClearContents

End If

End If
Next
MsgBox ("data cleared")
' scan files
n = 100
Do While Len(sFile) > 0
Set wbData = Workbooks.Open(sFolder & "" & sFile, ReadOnly:=True) ' updatelink, readonly
' open each sheet in turn
For Each wsData In wbData.Sheets
' find the filter column in row 1
Set rng = wsData.Rows(1).Find(FILTER_COL, LookAt:=xlWhole)

If Not rng Is Nothing Then
colno = rng.Column
iLastRow = wsData.Cells(Rows.Count, colno).End(xlUp).Row
If iLastRow > 1 Then
' range to copy and apply filter to one column
Set rng = rng.Resize(iLastRow, 1)
'rng.AutoFilter Field:=1, Criteria1:=crit, Operator:=xlFilterValues

OFLastCol = wsData.Range("A1").End(xlToRight).Column
OFLastRow = wsData.Cells(wsData.Rows.Count, OFLastCol).End(xlUp).Row
Set rng = wsData.Range("A1", wsData.Cells(OFLastRow, OFLastCol))
rng.AutoFilter Field:=colno, Criteria1:=crit, Operator:=xlFilterValues
Set rng = rng.SpecialCells(xlCellTypeVisible)
' is there data to copy
If rng.Rows.Count > 1 Or rng.Areas.Count > 1 Then

' check sheet available
sCodeName = "Sheet" & n
If dict.exists(sCodeName) Then
Set wsMaster = wbMaster.Sheets(dict(sCodeName))
Else
MsgBox sCodeName & " not found", vbCritical
Exit Sub
End If

' copy / paste all columns of visible rows
wsData.UsedRange.SpecialCells(xlCellTypeVisible).Copy
With wsMaster.Cells(TARGET_ROWNO, TARGET_COLNO)
.PasteSpecial Paste:=xlPasteValues
End With
'wsMaster.Range("G1").Select
'Selection.PasteSpecial Paste:=xlPasteValues, _
'Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
wsMaster.Activate
wsMaster.Range("A1").Select
Else
MsgBox "No data after filter on sheet " & wsData.Name, vbExclamation, wbData.Name
End If
Else
MsgBox "No data in column " & colno & " on sheet " & wsData.Name, vbExclamation, wbData.Name
End If
Else
MsgBox FILTER_COL & " not found on sheet " & wsData.Name, vbExclamation, wbData.Name
End If
n = n + 1 ' next data sheet
Next
wbData.Close False
sFile = Dir() ' next file in folder
Loop
MsgBox sFolder & " files scanned for option " & sOption, vbInformation
End Sub