Copy to new workbook and remove blank rows

[Morpheus]

Hi all, this is driving me completely crazy, i'm far from a vba expert, hope you can help.

So I have a quite large workbook open that creates a production routing for ORACLE JDE. The following code is behind a form control button.
It's supposed to create,name & save a new workbook and copy a range to it from a different sheet called "clipboard" in the same workbook other than the one the button is on (Also - the button is on a frozen top pane).
This sheet with the button on is called "MOM" now named wsI in the code (stands for method of manufacture), then it's supposed to remove any blank rows.
It creates and saves the new workbook but I cant get it to remove the blank rows, i get a variation of error messages based around subscript out of range. I mention the frozen panes because It did briefly work in a flaky way when i played around with freezing/unfreezing panes, but not robust enough to rely on, then it stopped altogether.
It seems that when i create & save the new workbook (wbo) it is the active workbook as it is on top of the original & is in focus but if i add a message box to return name of active workbook it shows (wbi). But whatever i do to try to make the right sheet active at the right time it doesn't work.

I don't mind going about it an entirely different way if anyone can suggest, all i want is a new workbook with the blank rows removed.

Many thanks in advance

VBA Code:

Sub CopyToNewBook()

Dim wbI As Workbook, wbO As Workbook
Dim wsI As Worksheet, wsO As Worksheet
Dim loc As Range
Dim DateTime As String
Dim Spath As String
Dim User As String
Dim r As Range, rows As Long, i As Long
   
      
DateTime = Format(CStr(Now), "ddmmyyyy" & " " & "hhmmss")
Set loc = Range("k2") 'contains the filepath to save to
User = Environ("Username") & " " & "Backup" & " "
Spath = loc & "" & User & DateTime

'~~> Source/Input Workbook
Set wbI = ThisWorkbook

'~~> Set the relevant sheet from where you want to copy
Set wsI = wbI.Sheets("Clipboard")

'~~> Destination/Output Workbook
Set wbO = Workbooks.Add

With wbO
        '~~> Set the relevant sheet to where you want to paste
        Set wsO = wbO.Sheets("Sheet1")

        '~~>. Save the file
        .SaveAs Filename:=Spath & ".XLSX", FileFormat:=56

        '~~> Copy the range
        wsI.Range("c1:eek:549").Copy

        '~~> Paste it in say Cell A1.
        wsO.Range("A1").PasteSpecial Paste:=xlPasteValues
       
        Application.CutCopyMode = False
       
               
    'remove blank rows
   
    Set r = wbO.Worksheets("Sheet1").Range("a1:m549")
    rows = r.rows.Count
    For i = rows To 1 Step (-1)
    If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete
    Next
   
End With

End Sub

[paulked]

Hi and welcome to the forum.

Make sure you have a valid path in K2 eg C:\Temp\ and try

Sub CopyToNewBook()

    Dim wbI As Workbook, wbO As Workbook
    Dim wsI As Worksheet, wsO As Worksheet
    Dim loc As Range
    Dim DateTime As String
    Dim Spath As String
    Dim User As String
    Dim r As Range, rows As Long, i As Long
   
    DateTime = Format(CStr(Now), "ddmmyyyy hhmmss")
    
    Set loc = Range("k2") 'contains the filepath to save to
    User = Environ("Username") & " Backup "
    Spath = loc & User & DateTime

    '~~> Source/Input Workbook
    Set wbI = ThisWorkbook

    '~~> Set the relevant sheet from where you want to copy
    Set wsI = wbI.Sheets("Clipboard")

    '~~> Destination/Output Workbook
    Set wbO = Workbooks.Add

    With wbO

        '~~>. Save the file
        .SaveAs Filename:=Spath & ".XLSX", FileFormat:=56

        '~~> Copy & paste the range
        wsI.Range("c1:eek549").Copy Range("A1")
       
        Application.CutCopyMode = False
               
        'remove blank rows
   
        Set r = .Worksheets("Sheet1").Range("a1:m549")
        rows = r.rows.Count
        For i = rows To 1 Step (-1)
            If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete
        Next
   
    End With

: