CODEWITHSUNDEEP
vbaexcel
Mikz
Mikz

Reputation: 591

Saving a xlsx file in a particular folder

I am trying to copy the content from source workbook to a new workbook and save it in xlsx format in a specified folder.

I am trying the below code and I get application defined error in the Last line of the code, where I am trying to save my new workbook as .xlsx

Also, It takes long time approx. 5min for this small piece of code. 

Sub newWB()
Dim myWksht As String
Dim newWB As Workbook
Dim MyBook As Workbook
Dim i As Integer, j As Integer
Dim LastRow As Long, totalrows As Long
Dim path1, path2  As String

path1 = ThisWorkbook.Path
path2 = path1 & "\Tru\Sq\"
Set newWB = Workbooks.Add


With ThisWorkbook.Worksheets("Pivottabelle")
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With


With newWB.Sheets("Sheet1")
    .Name = "PivotTable"
    j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With

With Worksheets("Pivottabelle")
    For i = 1 To LastRow
      ThisWorkbook.Sheets("Pivottabelle").Range("A1:Y400").Copy: newWB.Sheets("PivotTable").PasteSpecial
    Next i
End With

With newWB.Worksheets("PivotTable")
    totalrows = .Cells(.Rows.Count, "A").End(xlUp).Row
    For i = totalrows To 2 Step -1
        If .Cells(i, 8).Value <> "TRU" Then
        Cells(i, 8).EntireRow.Delete
        End If
Next
newWB.SaveAs Filename:=path2 & ".xlsx"
End With
End Sub

Upvotes: 0

Views: 92

Answers (1)

Pᴇʜ
Pᴇʜ

Reputation: 57673

This should show all the improvements from the comments (plus some more) …

It can be that you run into issues when saving because this

DestinationPath = ThisWorkbook.Path & "\Tru\Sq\"

only works if the macro containing workbook is already saved. Otherwise ThisWorkbook.Path is empty. And you probably need to be sure that these subfolders already exist.

Option Explicit 'force variable declare

Public Sub AddNewWorkbook() 'sub and newWB had the same name (no good practice)
    'Dim myWksht As String 'not used therefore can be removed
    Dim newWB As Workbook
    'Dim MyBook As Workbook 'not used therefore can be removed
    'Dim i As Integer, j As Integer
    Dim i As Long, j As Long 'use long instead of integer whenever possible
                             'see https://stackoverflow.com/a/26409520/3219613
    Dim LastRow As Long, totalrows As Long
    'Dim path1, path2 As String 'always specify a type for every variable
    Dim DestinationPath As String 'we only need one path

    DestinationPath = ThisWorkbook.Path & "\Tru\Sq\"
    'path2 = path1 & "\Tru\Sq\" ' can be reduced to one path

    Set newWB = Workbooks.Add

    With ThisWorkbook.Worksheets("Pivottabelle")
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With

    With newWB.Sheets("Sheet1")
        .Name = "PivotTable"
        j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    End With

    'With Worksheets("Pivottabelle") 'unecessary with (not used at all)
        'For i = 1 To LastRow 'unecessary loop
    ThisWorkbook.Sheets("Pivottabelle").Range("A1:Y400").Copy
    newWB.Sheets("PivotTable").PasteSpecial
        'Next i
    'End With

    With newWB.Worksheets("PivotTable")
        totalrows = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = totalrows To 2 Step -1
            If .Cells(i, 8).Value <> "TRU" Then
                .Cells(i, 8).EntireRow.Delete 'was missing a . before Cells(i, 8).EntireRow.Delete
            End If
        Next

        newWB.SaveAs Filename:=DestinationPath & "FILENAME" & ".xlsx" 'was missing a filename
    End With
End Sub

Upvotes: 2

Related Questions