Копировать / Вставить отфильтрованные данные
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