仅将经过过滤的数据/可见单元格从多个工作表复制到新工作簿中

问题描述 投票：0回答：1

如何将每个工作表（总共8个工作表）中筛选出的数据仅复制到新工作簿中？每个工作表的筛选标题都不同，从行开始就不需要。

我在这里发布了两组代码，感谢您的帮助/建议，谢谢！

  1. 我写了一个愚蠢的过滤方法，因为对于一个不了解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
  1. 我想将所有工作表的筛选数据（可见单元格）从一个工作簿复制到另一个工作簿。我尝试在下面的代码下运行，但它复制了所有数据，包括那些从筛选器中隐藏的数据。
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
excel vba filtering visible
1个回答
0
投票

复制/粘贴过滤后的数据

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
最新问题
© www.soinside.com 2019 - 2024. All rights reserved.