Question

我已经记录并使用了旧宏中的一些代码，但是当我尝试将它们拼凑在一起时它似乎不起作用。

我在谷歌上度过了整整一天，试图将其分解，但似乎无法让它发挥作用。

我们有一个包含各种功能的大型数据文件和大量的分析，我想将单独的工作簿发送到所有这些功能，但只包含相关数据。

我正在尝试从主工作簿中选择3张，复制到新书，然后使用过滤器删除不相关的行并将工作簿保存为函数名称和其他一些文本进行编辑。

我正在使用宏的列表来创建具有列表名称的每个文件。

Sub Create_SubFunction_Files()


    Dim iToDoRow As Integer, rSubFunction as String


    Application.ScreenUpdating = False

       For iToDoRow = 5 To 14

            If UCase(Cells(iToDoRow, 2)) = "YES" Then

                Range("rSubFunction") = Cells(iToDoRow, 1)


        Sheets(Array("Data", "Risk Summary", "Checklist")).Select
        Sheets("Data").Activate

        Sheets(Array("Data", "Risk Summary", "Checklist")).Copy

'Filter and Delete irrelevant rows

    Sheets("Data").Activate

    ActiveSheet.Range("A13:OW" & UsedRange.Rows.Count).AutoFilter Field:=2, Criteria1:="<>" & Range("rSubFunction"), Operator:=xlFilterValues


    Rows("14:" & UsedRange.Rows.Count).Select

    Selection.Delete Shift:=xlUp

    ActiveSheet.Range("A13:OW" & UsedRange.Rows.Count).AutoFilter Field:=2
  
         'Saveas target


     ActiveWorkbook.Save

     Application.DisplayAlerts = False

     ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & "\" & Range("rSubFunction") & " " & Cells(1, 2) & " Milestone & Finance Planner " & Cells(2, 2) & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

End If

    Next iToDoRow

  Application.ScreenUpdating = True
   

    MsgBox "Done :)", vbExclamation

End Sub

声明行，For，If和Save工作簿都以红色突出显示错误。

使用我的For / If语句，它不会接收Next / End如果进一步向下，它可能在错误的位置。

我真的看不出保存工作簿有什么问题，即使我删除所有内容并只留下一个基本名称它仍然有错误并突出显示文件名。

Answer 1

你可以单步进入以下内容并告诉我哪一行出错了吗？

Sub Create_SubFunction_Files()

Dim iToDoRow As Integer, rSubFunction As String

Application.ScreenUpdating = False

   For iToDoRow = 5 To 14
        If UCase(Cells(iToDoRow, 2)) = "YES" Then
            rSubFunction = Cells(iToDoRow, 1).Value
            Sheets(Array("Data", "Risk Summary", "Checklist")).Copy
                'Filter and Delete irrelevant rows
            Sheets("Data").Activate
            ActiveSheet.Range("A13:OW" & UsedRange.Rows.Count).AutoFilter Field:=2, Criteria1:="<>" & rSubFunction, Operator:=xlFilterValues
            Rows("14:" & UsedRange.Rows.Count).Select
            Selection.Delete Shift:=xlUp
            ActiveSheet.Range("A13:OW" & UsedRange.Rows.Count).AutoFilter Field:=2
                'Saveas target
            ActiveWorkbook.Save
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & "\" & rSubFunction & " " & Cells(1, 2) & " Milestone & Finance Planner " & Cells(2, 2) & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        End If
    Next iToDoRow

Application.ScreenUpdating = True
MsgBox "Done :)"

End Sub

宏将工作表复制到新工作簿，编辑工作簿和另存为

1 个答案: