Question

我正在尝试将内容从源工作簿复制到新工作簿，并将其以xlsx格式保存在指定的文件夹中。

我正在尝试下面的代码，我在代码的最后一行得到应用程序定义的错误，我试图将我的新工作簿保存为.xlsx

此外，大约需要很长时间。这段小代码需要5分钟。

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

Answer 1

这应该显示评论的所有改进（加上更多）......

可能因为这个

而在保存时遇到问题

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

仅在已保存包含工作簿的宏时才有效。否则ThisWorkbook.Path为空。您可能需要确保这些子文件夹已经存在。

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

将xlsx文件保存在特定文件夹中

1 个答案: