Macro Copying sheets into a new workbook, editing workbook and Save As

Question

I have recorded and used bits of code from old macros, but when I try and piece it all together it does not seem to work.

I have spent all day on google, tried breaking it up, but can't seem to get it to work.

We have a large data file with various functions in it and loads of analysis, I'd like to send out sepaerate workbooks to all these functions, but only include the relevant data.

I am trying to select 3 sheets from the main workbook, copy to a new book then edit by deleting the irrelevant rows using a filter and saving the workbook as the Function name and some other text.

I am using a list for the macro to go through to create each file with the name from the list.

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

The Declaration line, For, If and Save workbook are all highlighted in red for an error.

With my For/If statements it's not picking up the Next/End If further down, it's probably in the wrong place.

I really can't see what is wrong with the Save workbook as, even if I delete all and just leave a basic name it still has an error and highlights Filename.

You have defined rSubFunction as a String, but then use it 'as a string' by putting it in " ". Have you used Step Into in VBA with F8 to check how each bit is working? — Tim Wilkinson
Hi, I've taken out the declaration for the string, it still does not seem to work. I've tried using F8, but it fails on the first line — RTorres82

Tim Wilkinson Tim Wilkinson · Accepted Answer · 2016-05-20T10:44:13

Can you Step Into the following and tell me which line you get the error on?

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

Macro Copying sheets into a new workbook, editing workbook and Save As

1 Answers