仅将过滤后的数据/可见单元格从多个工作表复制到新工作簿
Copy only filtered data / visible cells from multiple sheets to new workbook
如何仅将每个工作表（总共 8 个工作表）中过滤后的数据复制到新工作簿中？我筛选的 header 因每个工作表而异，不需要在 from 行。
我在这里发布了两套代码，感谢任何帮助/建议，谢谢！
- 我写的过滤方法很笨，对于 vba 知识不多的人来说，我想不出更好的方法来按国家/地区过滤多张表格。我必须在 8 个工作表中过滤国家/地区，并且我有大约 20++ 个国家/地区要过滤，参考在另一个工作簿的下拉列表中选择的国家/地区。下面是我为一个国家做的样本。
Sub FilterByCountry()
'Referencing the country selected
If Workbooks("PAP_Macro_v1.xlsm").Worksheets("Export by country").Range("C3") = "Australia" Then
'Filtering for each worksheet
Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx").Worksheets("Summary PAP").Range("A1:I1").AutoFilter _
Field:=1, _
Criteria1:="Australia", _
VisibleDropDown:=True
End If
If Workbooks("PAP_Macro_v1.xlsm").Worksheets("Export by country").Range("C3") = "Australia" Then
Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx").Worksheets("PAP").Range("A6:BK6").AutoFilter _
Field:=5, _
Criteria1:="Australia", _
VisibleDropDown:=True
End If
If Workbooks("PAP_Macro_v1.xlsm").Worksheets("Export by country").Range("C3") = "Australia" Then
Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx").Worksheets("PAP by Country").Range("B6:AV6").AutoFilter _
Field:=2, _
Criteria1:="Australia", _
VisibleDropDown:=True
End If
If Workbooks("PAP_Macro_v1.xlsm").Worksheets("Export by country").Range("C3") = "Australia" Then
Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx").Worksheets("PAP Target").Range("A1:I1").AutoFilter _
Field:=1, _
Criteria1:="Australia", _
VisibleDropDown:=True
End If
If Workbooks("PAP_Macro_v1.xlsm").Worksheets("Export by country").Range("C3") = "Australia" Then
Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx").Worksheets("Country Summary Month").Range("A4:AD4").AutoFilter _
Field:=1, _
Criteria1:="Australia", _
VisibleDropDown:=True
End If
If Workbooks("PAP_Macro_v1.xlsm").Worksheets("Export by country").Range("C3") = "Australia" Then
Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx").Worksheets("Users Summary Month").Range("A5:AK5").AutoFilter _
Field:=2, _
Criteria1:="Australia", _
VisibleDropDown:=True
End If
If Workbooks("PAP_Macro_v1.xlsm").Worksheets("Export by country").Range("C3") = "Australia" Then
Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx").Worksheets("Country Summary YTD").Range("A4:AG4").AutoFilter _
Field:=1, _
Criteria1:="Australia", _
VisibleDropDown:=True
End If
If Workbooks("PAP_Macro_v1.xlsm").Worksheets("Export by country").Range("C3") = "Australia" Then
Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx").Worksheets("Users Summary YTD").Range("A5:AJ5").AutoFilter _
Field:=2, _
Criteria1:="Australia", _
VisibleDropDown:=True
End If
End Sub
- 我想将所有工作表的筛选数据（可见单元格）从一个工作簿复制到另一个工作簿。我尝试 运行 下面的代码，但它复制了所有数据，包括那些隐藏在过滤器中的数据。
Sub exportS()
Dim NewName As String
Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx").Worksheets(Array("BU TEC PAP history", "Summary PAP", "PAP", "PAP by Country", _
"PAP Target", "Country Summary Month", "Users Summary Month", "Country Summary YTD", "Users Summary YTD")).Copy
NewName = InputBox("Please Specify the name of your new workbook", "Export by Country", "SFDC_2020-xx_(PAP)-[country]")
With ActiveWorkbook
.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xlsx"
.Close SaveChanges:=False
End With
End Sub
Copy/Paste 筛选数据
Option Explicit
Sub exportS() ' !!! Tested !!!
Dim wbSFDC As Workbook ' Source Workbook
Set wbSFDC = Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx")
Dim vntW ' Worksheet Name Array
vntW = Array("BU TEC PAP history", _
"Summary PAP", "PAP", "PAP by Country", "PAP Target", _
"Country Summary Month", "Users Summary Month", _
"Country Summary YTD", "Users Summary YTD")
Dim vntR ' Range Array
vntR = Array("A1:I1", _
"A1:I1", "A6:BK6", "B6:AV6", "A1:I1", _
"A4:AD4", "A5:AK5", _
"A4:AG4", "A5:AJ5")
Dim vntF ' Field Array
vntF = Array(1, _
1, 5, 2, 1, 1, 2, 1, 2)
Dim wbExport As Workbook ' Export Workbook
Dim NoSInit As Long ' Initial Value of SheetsInNewWorkbook
Dim NoS As Long ' Number of Sheets
Dim FilR As Long ' Filter Row
Dim FilC As Long ' Filter Column
Dim LR As Long ' Last Row
Dim LC As Long ' Last Column
Dim i As Long ' Array Counter
Dim NewName As Variant ' New Workbook Name (Application.InputBox)
Dim MsgSave As Variant ' Save Message Box
Dim blnSave As Boolean ' Save Boolean
With Application
.ScreenUpdating = False
End With
On Error GoTo ProgramError
' Create a new workbook with the number of sheets equal to the number
' of sheets that are being copied.
NoS = UBound(vntW) + 1
With Application
If .SheetsInNewWorkbook <> NoS Then
NoSInit = .SheetsInNewWorkbook
.SheetsInNewWorkbook = NoS
End If
.Workbooks.Add: Set wbExport = .ActiveWorkbook
If NoSInit <> NoS Then .SheetsInNewWorkbook = NoSInit
End With
' Copy data from sheets of Source to sheets of Report Workbook.
' Looping backwards for the first sheet to be active at the end of the loop.
For i = NoS - 1 To 0 Step -1
With wbExport.Worksheets(i + 1)
.Name = vntW(i)
With wbSFDC.Worksheets(vntW(i))
FilR = .Range(vntR(i)).Row
LC = .Cells(FilR, .Columns.Count).End(xlToLeft).Column
FilC = .Range(vntR(i)).Column + vntF(i) - 1
LR = .Cells(.Rows.Count, FilC).End(xlUp).Row
.Range(.Cells(1, 1), .Cells(LR, LC)).Copy
End With
.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
' for "A1" to be selected in each sheet.
.Activate
.Cells(1, 1).Select
End With
Next i
' Save Export Workbook.
Do ' Note: Application.InputBox is different than InputBox
NewName = Application.InputBox( _
"Please Specify the name of your new workbook", _
"Export by Country", "SFDC_2020-xx_(PAP)-[country]")
If NewName = False Then ' Application.InputBox "Cancel"
MsgSave = MsgBox("Really cancel the save?", _
vbYesNo + vbCritical)
If MsgSave = vbYes Then
MsgBox "You cancelled the save. Closing and not saving " _
& "Workbook '" & wbExport.Name & "'!", vbInformation
wbExport.Close False
GoTo ProcedureExit
End If
Else ' Application.InputBox "OK"
With wbExport
' Here you should validate the input before saving and only
' then set blnSave to True.
' *** Do not save while testing
'.SaveAs wbSFDC.Path & "\" & NewName & ".xlsx"
'.Close ' Close Export Workbook ???
blnSave = True
' *** Only while testing
MsgBox "While testing, not saved workbook '" _
& NewName & "'.", vbInformation
.Saved = True
' *** Only while testing
End With
End If
Loop Until blnSave = True
' Close Source Workbook.
With wbSFDC
' *** Do not close while testing.
'.Close False ' Close Source Workbook without saving.
End With
ProcedureSucces:
MsgBox "Operation finished successfully.", vbInformation
ProcedureExit:
With Application
.ScreenUpdating = False
End With
Exit Sub
ProgramError:
' You can do better.
MsgBox "Error '" & Err.Number & "':" & Err.Description, vbCritical
On Error GoTo 0
GoTo ProcedureExit
End Sub
Sub FilterByCountry() ' !!! Not Tested !!!
Const strC As String = "Australia"
' Workbooks that have to be open:
' "PAP_Macro_v1.xlsm"
' "SFDC_2020-xx_(PAP)-WD.xlsx"
Dim vntW, vntR, vntF
vntW = Array("Summary PAP", "PAP", "PAP by Country", "PAP Target", _
"Country Summary Month", "Users Summary Month", _
"Country Summary YTD", "Users Summary YTD")
vntR = Array("A1:I1", "A6:BK6", "B6:AV6", "A1:I1", _
"A4:AD4", "A5:AK5", _
"A4:AG4", "A5:AJ5")
vntF = ARrray(1, 5, 2, 1, 1, 2, 1, 2)
Dim rngExport As Range: Set rngExport = Workbooks("PAP_Macro_v1.xlsm") _
.Worksheets("Export by country").Range("C3")
Dim wbSFDC As Workbook: Set wbSFDC = Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx")
Dim i As Long
' Referencing the country selected
If rngExport = strC Then
For i = 0 To UBound(vntW)
wbSFDC.Worksheets(vntW(i)).Range(vntR(i)).AutoFilter _
Field:=vntF(i), Criteria1:=strC, VisibleDropDown:=True
Next
End If
End Sub
' You can do this ...
Sub FBC(CountryName) ' !!! Not Tested !!!
' Workbooks that have to be open:
' "PAP_Macro_v1.xlsm"
' "SFDC_2020-xx_(PAP)-WD.xlsx"
Dim vntW, vntR, vntF
vntW = Array("Summary PAP", "PAP", "PAP by Country", "PAP Target", _
"Country Summary Month", "Users Summary Month", _
"Country Summary YTD", "Users Summary YTD")
vntR = Array("A1:I1", "A6:BK6", "B6:AV6", "A1:I1", _
"A4:AD4", "A5:AK5", _
"A4:AG4", "A5:AJ5")
vntF = ARrray(1, 5, 2, 1, 1, 2, 1, 2)
Dim rngExport As Range: Set rngExport = Workbooks("PAP_Macro_v1.xlsm") _
.Worksheets("Export by country").Range("C3")
Dim wbSFDC As Workbook: Set wbSFDC = Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx")
Dim i As Long
' Referencing the country selected
If rngExport = CountryName Then
For i = 0 To UBound(vntW)
wbSFDC.Worksheets(vntW(i)).Range(vntR(i)).AutoFilter _
Field:=vntF(i), Criteria1:=CountryName, VisibleDropDown:=True
Next
End If
End Sub
' ... and in another Sub you can use it like this:
Sub FBC2()
Dim Country As String
Country = "Australia"
FBC (Country)
End Sub
如何仅将每个工作表（总共 8 个工作表）中过滤后的数据复制到新工作簿中？我筛选的 header 因每个工作表而异，不需要在 from 行。
我在这里发布了两套代码，感谢任何帮助/建议，谢谢！
- 我写的过滤方法很笨，对于 vba 知识不多的人来说，我想不出更好的方法来按国家/地区过滤多张表格。我必须在 8 个工作表中过滤国家/地区，并且我有大约 20++ 个国家/地区要过滤，参考在另一个工作簿的下拉列表中选择的国家/地区。下面是我为一个国家做的样本。
Sub FilterByCountry()
'Referencing the country selected
If Workbooks("PAP_Macro_v1.xlsm").Worksheets("Export by country").Range("C3") = "Australia" Then
'Filtering for each worksheet
Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx").Worksheets("Summary PAP").Range("A1:I1").AutoFilter _
Field:=1, _
Criteria1:="Australia", _
VisibleDropDown:=True
End If
If Workbooks("PAP_Macro_v1.xlsm").Worksheets("Export by country").Range("C3") = "Australia" Then
Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx").Worksheets("PAP").Range("A6:BK6").AutoFilter _
Field:=5, _
Criteria1:="Australia", _
VisibleDropDown:=True
End If
If Workbooks("PAP_Macro_v1.xlsm").Worksheets("Export by country").Range("C3") = "Australia" Then
Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx").Worksheets("PAP by Country").Range("B6:AV6").AutoFilter _
Field:=2, _
Criteria1:="Australia", _
VisibleDropDown:=True
End If
If Workbooks("PAP_Macro_v1.xlsm").Worksheets("Export by country").Range("C3") = "Australia" Then
Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx").Worksheets("PAP Target").Range("A1:I1").AutoFilter _
Field:=1, _
Criteria1:="Australia", _
VisibleDropDown:=True
End If
If Workbooks("PAP_Macro_v1.xlsm").Worksheets("Export by country").Range("C3") = "Australia" Then
Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx").Worksheets("Country Summary Month").Range("A4:AD4").AutoFilter _
Field:=1, _
Criteria1:="Australia", _
VisibleDropDown:=True
End If
If Workbooks("PAP_Macro_v1.xlsm").Worksheets("Export by country").Range("C3") = "Australia" Then
Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx").Worksheets("Users Summary Month").Range("A5:AK5").AutoFilter _
Field:=2, _
Criteria1:="Australia", _
VisibleDropDown:=True
End If
If Workbooks("PAP_Macro_v1.xlsm").Worksheets("Export by country").Range("C3") = "Australia" Then
Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx").Worksheets("Country Summary YTD").Range("A4:AG4").AutoFilter _
Field:=1, _
Criteria1:="Australia", _
VisibleDropDown:=True
End If
If Workbooks("PAP_Macro_v1.xlsm").Worksheets("Export by country").Range("C3") = "Australia" Then
Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx").Worksheets("Users Summary YTD").Range("A5:AJ5").AutoFilter _
Field:=2, _
Criteria1:="Australia", _
VisibleDropDown:=True
End If
End Sub
- 我想将所有工作表的筛选数据（可见单元格）从一个工作簿复制到另一个工作簿。我尝试 运行 下面的代码，但它复制了所有数据，包括那些隐藏在过滤器中的数据。
Sub exportS()
Dim NewName As String
Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx").Worksheets(Array("BU TEC PAP history", "Summary PAP", "PAP", "PAP by Country", _
"PAP Target", "Country Summary Month", "Users Summary Month", "Country Summary YTD", "Users Summary YTD")).Copy
NewName = InputBox("Please Specify the name of your new workbook", "Export by Country", "SFDC_2020-xx_(PAP)-[country]")
With ActiveWorkbook
.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xlsx"
.Close SaveChanges:=False
End With
End Sub
Copy/Paste 筛选数据
Option Explicit
Sub exportS() ' !!! Tested !!!
Dim wbSFDC As Workbook ' Source Workbook
Set wbSFDC = Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx")
Dim vntW ' Worksheet Name Array
vntW = Array("BU TEC PAP history", _
"Summary PAP", "PAP", "PAP by Country", "PAP Target", _
"Country Summary Month", "Users Summary Month", _
"Country Summary YTD", "Users Summary YTD")
Dim vntR ' Range Array
vntR = Array("A1:I1", _
"A1:I1", "A6:BK6", "B6:AV6", "A1:I1", _
"A4:AD4", "A5:AK5", _
"A4:AG4", "A5:AJ5")
Dim vntF ' Field Array
vntF = Array(1, _
1, 5, 2, 1, 1, 2, 1, 2)
Dim wbExport As Workbook ' Export Workbook
Dim NoSInit As Long ' Initial Value of SheetsInNewWorkbook
Dim NoS As Long ' Number of Sheets
Dim FilR As Long ' Filter Row
Dim FilC As Long ' Filter Column
Dim LR As Long ' Last Row
Dim LC As Long ' Last Column
Dim i As Long ' Array Counter
Dim NewName As Variant ' New Workbook Name (Application.InputBox)
Dim MsgSave As Variant ' Save Message Box
Dim blnSave As Boolean ' Save Boolean
With Application
.ScreenUpdating = False
End With
On Error GoTo ProgramError
' Create a new workbook with the number of sheets equal to the number
' of sheets that are being copied.
NoS = UBound(vntW) + 1
With Application
If .SheetsInNewWorkbook <> NoS Then
NoSInit = .SheetsInNewWorkbook
.SheetsInNewWorkbook = NoS
End If
.Workbooks.Add: Set wbExport = .ActiveWorkbook
If NoSInit <> NoS Then .SheetsInNewWorkbook = NoSInit
End With
' Copy data from sheets of Source to sheets of Report Workbook.
' Looping backwards for the first sheet to be active at the end of the loop.
For i = NoS - 1 To 0 Step -1
With wbExport.Worksheets(i + 1)
.Name = vntW(i)
With wbSFDC.Worksheets(vntW(i))
FilR = .Range(vntR(i)).Row
LC = .Cells(FilR, .Columns.Count).End(xlToLeft).Column
FilC = .Range(vntR(i)).Column + vntF(i) - 1
LR = .Cells(.Rows.Count, FilC).End(xlUp).Row
.Range(.Cells(1, 1), .Cells(LR, LC)).Copy
End With
.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
' for "A1" to be selected in each sheet.
.Activate
.Cells(1, 1).Select
End With
Next i
' Save Export Workbook.
Do ' Note: Application.InputBox is different than InputBox
NewName = Application.InputBox( _
"Please Specify the name of your new workbook", _
"Export by Country", "SFDC_2020-xx_(PAP)-[country]")
If NewName = False Then ' Application.InputBox "Cancel"
MsgSave = MsgBox("Really cancel the save?", _
vbYesNo + vbCritical)
If MsgSave = vbYes Then
MsgBox "You cancelled the save. Closing and not saving " _
& "Workbook '" & wbExport.Name & "'!", vbInformation
wbExport.Close False
GoTo ProcedureExit
End If
Else ' Application.InputBox "OK"
With wbExport
' Here you should validate the input before saving and only
' then set blnSave to True.
' *** Do not save while testing
'.SaveAs wbSFDC.Path & "\" & NewName & ".xlsx"
'.Close ' Close Export Workbook ???
blnSave = True
' *** Only while testing
MsgBox "While testing, not saved workbook '" _
& NewName & "'.", vbInformation
.Saved = True
' *** Only while testing
End With
End If
Loop Until blnSave = True
' Close Source Workbook.
With wbSFDC
' *** Do not close while testing.
'.Close False ' Close Source Workbook without saving.
End With
ProcedureSucces:
MsgBox "Operation finished successfully.", vbInformation
ProcedureExit:
With Application
.ScreenUpdating = False
End With
Exit Sub
ProgramError:
' You can do better.
MsgBox "Error '" & Err.Number & "':" & Err.Description, vbCritical
On Error GoTo 0
GoTo ProcedureExit
End Sub
Sub FilterByCountry() ' !!! Not Tested !!!
Const strC As String = "Australia"
' Workbooks that have to be open:
' "PAP_Macro_v1.xlsm"
' "SFDC_2020-xx_(PAP)-WD.xlsx"
Dim vntW, vntR, vntF
vntW = Array("Summary PAP", "PAP", "PAP by Country", "PAP Target", _
"Country Summary Month", "Users Summary Month", _
"Country Summary YTD", "Users Summary YTD")
vntR = Array("A1:I1", "A6:BK6", "B6:AV6", "A1:I1", _
"A4:AD4", "A5:AK5", _
"A4:AG4", "A5:AJ5")
vntF = ARrray(1, 5, 2, 1, 1, 2, 1, 2)
Dim rngExport As Range: Set rngExport = Workbooks("PAP_Macro_v1.xlsm") _
.Worksheets("Export by country").Range("C3")
Dim wbSFDC As Workbook: Set wbSFDC = Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx")
Dim i As Long
' Referencing the country selected
If rngExport = strC Then
For i = 0 To UBound(vntW)
wbSFDC.Worksheets(vntW(i)).Range(vntR(i)).AutoFilter _
Field:=vntF(i), Criteria1:=strC, VisibleDropDown:=True
Next
End If
End Sub
' You can do this ...
Sub FBC(CountryName) ' !!! Not Tested !!!
' Workbooks that have to be open:
' "PAP_Macro_v1.xlsm"
' "SFDC_2020-xx_(PAP)-WD.xlsx"
Dim vntW, vntR, vntF
vntW = Array("Summary PAP", "PAP", "PAP by Country", "PAP Target", _
"Country Summary Month", "Users Summary Month", _
"Country Summary YTD", "Users Summary YTD")
vntR = Array("A1:I1", "A6:BK6", "B6:AV6", "A1:I1", _
"A4:AD4", "A5:AK5", _
"A4:AG4", "A5:AJ5")
vntF = ARrray(1, 5, 2, 1, 1, 2, 1, 2)
Dim rngExport As Range: Set rngExport = Workbooks("PAP_Macro_v1.xlsm") _
.Worksheets("Export by country").Range("C3")
Dim wbSFDC As Workbook: Set wbSFDC = Workbooks("SFDC_2020-xx_(PAP)-WD.xlsx")
Dim i As Long
' Referencing the country selected
If rngExport = CountryName Then
For i = 0 To UBound(vntW)
wbSFDC.Worksheets(vntW(i)).Range(vntR(i)).AutoFilter _
Field:=vntF(i), Criteria1:=CountryName, VisibleDropDown:=True
Next
End If
End Sub
' ... and in another Sub you can use it like this:
Sub FBC2()
Dim Country As String
Country = "Australia"
FBC (Country)
End Sub