excel - VBA - 根据列表更改单元格，然后根据该单元格/列表保存新工作簿

Question

我已经有一个带有宏的工作簿，该宏可以根据单元格值执行几项操作：

当我更改单元格值（它的商店名称）时，代码将过滤几张纸，只是为了显示该特定单元格的商店，然后隐藏几张纸。仅显示 2 个特定工作表。在代码的末尾，我用该商店的名称保存了一个新工作簿。

我的问题是：

是否可以更改我的代码（如下所示），因此我不必手动编写商店的名称，即我希望宏看到商店列表，然后更改每个商店的单元格，完成所有任务我想要，然后用该商店名称编写一个新工作簿，依此类推，直到列表商店结束？

非常感谢

（PS：我是 vba 的新手，所以我的代码可能有点粗糙）

Sub Nova_loja()

   Dim sht As Worksheet
   Dim Fname As String
   Dim Cell As Range, cRange As Range

    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False

    'copy past in values

    With Range("K44:L66")
        .Cells.Copy
        .Cells.PasteSpecial xlPasteValues
    End With

    Application.CutCopyMode = False

  'filter and delete

    Sheets("BD Geral").Select
    ActiveSheet.ListObjects("Table2").Range.AutoFilter Field:=52, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B2").value, Operator:=xlFilterValues

    Application.DisplayAlerts = False
    ActiveSheet.ListObjects("Table2").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
    Application.DisplayAlerts = True

    ActiveSheet.ListObjects("Table2").AutoFilter.ShowAllData

    'filter and delete

    Sheets("BD BONUS_MALUS").Select
    ActiveSheet.ListObjects("Table35").Range.AutoFilter Field:=3, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").value, Operator:=xlFilterValues

    Application.DisplayAlerts = False
    ActiveSheet.ListObjects("Table35").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
    Application.DisplayAlerts = True


    ActiveSheet.ListObjects("Table35").AutoFilter.ShowAllData


    'filter and delete

    Sheets("BD NPS").Select
    ActiveSheet.ListObjects("Table3").Range.AutoFilter Field:=2, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").value, Operator:=xlFilterValues

    Application.DisplayAlerts = False
    ActiveSheet.ListObjects("Table3").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
    Application.DisplayAlerts = True

    ActiveSheet.ListObjects("Table3").AutoFilter.ShowAllData


    Sheets("BD Dept").Select
    ActiveSheet.ListObjects("Table4").Range.AutoFilter Field:=8, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").value, Operator:=xlFilterValues

    Application.DisplayAlerts = False
    ActiveSheet.ListObjects("Table4").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
    Application.DisplayAlerts = True

    ActiveSheet.ListObjects("Table4").AutoFilter.ShowAllData




    'refresh pivots

    ThisWorkbook.RefreshAll


    'hide sheets

    For Each sht In ThisWorkbook.Worksheets
    If sht.Name <> "Dashboard" And sht.Name <> "Tabela - Média Mensal" Then
    sht.Visible = xlSheetVeryHidden
    End If
    Next sht



    'protect sheets

    For Each sht In ActiveWorkbook.Sheets
       sht.Protect Password:="fnacrh", AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
    Next



    'leave active main worksheet

    Sheets("Dashboard").Select



    'save as with new name

    Application.DisplayAlerts = False





    Fname = ThisWorkbook.Path & "\" & "02.VIM_REPORT MENSAL - " & Worksheets("aux").Range("V2") & " - " & Worksheets("aux").Range("V3") & ".xlsx"
    ActiveWorkbook.SaveAs Filename:=Fname, FileFormat:=xlWorkbookDefault







    Application.DisplayAlerts = True


    Application.DisplayStatusBar = True
    Application.ScreenUpdating = True




End Sub

非常感谢

标签： excelvba

Answer 1

下一个代码会做我理解你需要的。将下一个代码复制到另一个工作簿的模块中，与要处理的模块不同，然后运行AutomaticallySelectStore程序。将出现一个 InputBox，要求从要处理的工作簿名称右侧选择数字。

   Sub AutomaticallySelectStore()
            Dim w As Workbook, Wb As Workbook, sh As Worksheet, store As Variant, Arr As Variant, Ans As String
            Dim i As Long, strWorkb As String, strWbName As String, strWbPath As String, nrStores As Long

            strWorkb = "Please write the number of the workbook needed to be processed:" & vbCrLf & vbCrLf

            For Each Wb In Workbooks
                i = i + 1
                strWorkb = strWorkb & Wb.name & " - " & i & vbCrLf
            Next
            strWorkb = left(strWorkb, Len(strWorkb) - 1)
            Ans = InputBox(strWorkb, "Necessary workbook selection", 1)
              If Ans = "" Then MsgBox "You did not select anything...", vbInformation, "No workbook selected": Exit Sub
              If Not IsNumeric(Ans) Then
                MsgBox "You must write the number from the right side of the needed workbook name!", vbInformation, _
                        "Wrong choice...": Exit Sub
              ElseIf Ans > Workbooks.Count Then
                MsgBox "You must write a number less or equal with " & Workbooks.Count, vbInformation, _
                        "Wrong chosen number": Exit Sub
              End If

            Set w = Workbooks(CLng(Ans))

             On Error Resume Next
               Set sh = w.Worksheets("aux")
             If Err.Number <> 0 Then
                Err.Clear: On Error GoTo 0
                MsgBox "The chosen workbook looks to be wrong..." & vbCrLf & _
                       " Worksheet ""Tabela - Média Mensal"" is missing.", vbInformation, _
                       "Wrong workbook or necessary worksheet missing": Exit Sub
             End If
             On Error GoTo 0

             strWbName = w.FullName
             nrStores = sh.Range("AF2").End(xlDown).Row
             Arr = sh.Range("AF2:AF" & nrStores)
             w.Activate
             i = 0
             Application.Calculation = xlCalculationManual
              For Each store In Arr
                i = i + 1
                Nova_loja strWbName, store, i, nrStores - 1
              Next
             Application.Calculation = xlCalculationAutomatic
             Application.StatusBar = "Ready..."
        End Sub

    Sub Nova_loja(strWbName As String, store As Variant, No As Long, NrPag As Long)

       Dim sht As Worksheet, fName As String, Cell As Range, cRange As Range
       Dim w As Workbook, Wb As Workbook, boolFound As Boolean, shortName As String
       Dim Arr As Variant, shAr As Worksheet, shortWbName As String

       shortWbName = Right(strWbName, Len(strWbName) - InStrRev(strWbName, "\"))
       For Each Wb In Workbooks
            If Wb.FullName = strWbName Then
                Set w = Wb: boolFound = True: Exit For
            End If
       Next
       If Not boolFound Then
            Set w = Workbooks.Open(strWbName)
       End If

        Application.ScreenUpdating = False

        Application.StatusBar = "Working on " & store & " store (" & No & " of " & NrPag & ")..."
        Application.CalculateBeforeSave = True


        Set shAr = Workbooks(shortWbName).Worksheets("aux")
        Arr = shAr.Range("K44:L66")
        shAr.Range("K44:L66") = Arr


        Sheets("Tabela - Média Mensal").Range("B2").Value = store

        Sheets("BD Geral").ListObjects("Table2").Range.AutoFilter field:=52, Criteria1:="<>" & store, _
                                                                                    Operator:=xlFilterValues

        Application.DisplayAlerts = False
          Sheets("BD Geral").ListObjects("Table2").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
          Sheets("BD Geral").ListObjects("Table2").AutoFilter.ShowAllData 'it returns an error if no filter is applied
        Application.DisplayAlerts = True

        'filter and delete
        Sheets("BD BONUS_MALUS").ListObjects("Table35").Range.AutoFilter field:=3, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").Value, Operator:=xlFilterValues

        Application.DisplayAlerts = False
         Sheets("BD BONUS_MALUS").ListObjects("Table35").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
        Application.DisplayAlerts = True

        Sheets("BD BONUS_MALUS").ListObjects("Table35").AutoFilter.ShowAllData

        'filter and delete
        Sheets("BD NPS").ListObjects("Table3").Range.AutoFilter field:=2, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").Value, Operator:=xlFilterValues

        Application.DisplayAlerts = False
         Sheets("BD NPS").ListObjects("Table3").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
        Application.DisplayAlerts = True

        Sheets("BD NPS").ListObjects("Table3").AutoFilter.ShowAllData

        'This sheet does not contain any "Table"...
        Sheets("BD Dept").ListObjects("Table4").Range.AutoFilter field:=8, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").Value, Operator:=xlFilterValues

        Application.DisplayAlerts = False
         Sheets("BD Dept").ListObjects("Table4").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
        Application.DisplayAlerts = True

        Sheets("BD Dept").ListObjects("Table4").AutoFilter.ShowAllData

        'hide sheets
        For Each sht In w.Worksheets
            If sht.name <> "Dashboard" And sht.name <> "Tabela - Média Mensal" Then
                sht.Visible = xlSheetVeryHidden
            End If
        Next sht

        'protect sheets
        For Each sht In ActiveWorkbook.Sheets
           sht.Protect Password:="fnacrh", AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
        Next

        'leave active main worksheet
        Sheets("Dashboard").Select

        w.RefreshAll

        shortName = "02.VIM_REPORT MENSAL - " & store & " - " & Worksheets("aux").Range("V3") & ".xlsx"
        fName = w.Path & "\" & shortName
         Application.DisplayAlerts = False
          ActiveWorkbook.SaveAs Filename:=fName, FileFormat:=xlWorkbookDefault
          Workbooks(shortName).Close , False
        Application.DisplayAlerts = True

        Application.DisplayStatusBar = True
        Application.ScreenUpdating = True
    End Sub

请测试它并确认它是否按预期工作。如果没有，请提及发生了什么错误。