Vba 在特定文件夹中保存xlsx文件_Vba_Excel

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

vba excel

Vba 在特定文件夹中保存xlsx文件,vba,excel,Vba,Excel,我正在尝试将源工作簿中的内容复制到新工作簿，并将其以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

我正在尝试将源工作簿中的内容复制到新工作簿，并将其以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

Sub-newWB（）
作为字符串的Dim myWksht
将新WB设置为工作簿
将MyBook设置为工作簿
尺寸i为整数，j为整数
变暗最后一行为长，总计行为长
路径1变暗，路径2变为字符串
path1=ThisWorkbook.Path
路径2=路径1&“\Tru\Sq”
Set newWB=工作簿。添加
使用此工作簿。工作表（“数据透视表”）
LastRow=.Cells（.Rows.Count，“A”）.End（xlUp）.Row
以
使用新的工作表（“表1”）
.Name=“数据透视表”
j=.Cells（.Rows.Count，“A”）.End（xlUp）.Row+1
以
带工作表（“数据透视表”）
对于i=1到最后一行
ThisWorkbook.Sheets（“数据透视表”）.Range（“A1:Y400”）。Copy:newWB.Sheets（“数据透视表”）。PasteSpecial
接下来我
以
使用newWB.工作表（“数据透视表”）
totalrows=.Cells（.Rows.Count，“A”）.End（xlUp）.Row
对于i=totalrows到2步骤-1
如果.Cells（i，8）.值为“TRU”，则
单元格（i，8）.EntireRow.Delete
如果结束
下一个
newWB.SaveAs文件名：=路径2&“.xlsx”
以
端接头

这应该显示评论中的所有改进（以及更多的改进）

保存时可能会遇到问题，因为

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

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

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

选项显式“强制变量声明”
Public Sub AddNewWorkbook（）'Sub和newWB具有相同的名称（没有良好的实践）
“Dim myWksht As String”未使用，因此可以删除
将新WB设置为工作簿
“Dim MyBook As工作簿”未使用，因此可以删除
'尺寸i为整数，j为整数
Dim i As Long，j As Long’尽可能使用Long而不是整数
”“看到了吗https://stackoverflow.com/a/26409520/3219613
变暗最后一行为长，总计行为长
“Dim path1，path2 As String”始终为每个变量指定一种类型
Dim DestinationPath作为字符串“我们只需要一条路径
DestinationPath=ThisWorkbook.Path&“\Tru\Sq”
“path2=path1&“\Tru\Sq\”可以减少为一条路径
Set newWB=工作簿。添加
使用此工作簿。工作表（“数据透视表”）
LastRow=.Cells（.Rows.Count，“A”）.End（xlUp）.Row
以
使用新的工作表（“表1”）
.Name=“数据透视表”
j=.Cells（.Rows.Count，“A”）.End（xlUp）.Row+1
以
“With worksheet”（“Pivottabelle”）”不需要With（根本不使用）
“对于i=1到最后一行”不必要的循环
此工作簿.Sheets（“数据透视表”）.范围（“A1:Y400”）.副本
newWB.Sheets（“数据透视表”）.PasteSpecial
“接下来我
"以
使用newWB.工作表（“数据透视表”）
totalrows=.Cells（.Rows.Count，“A”）.End（xlUp）.Row
对于i=totalrows到2步骤-1
如果.Cells（i，8）.值为“TRU”，则
.Cells（i，8）.EntireRow.Delete'缺少一个。在单元格（i，8）之前.EntireRow.Delete
如果结束
下一个
newWB.SaveAs Filename:=DestinationPath&“Filename”&“.xlsx”缺少文件名
以
端接头

这应该显示评论中的所有改进（以及更多的改进）

保存时可能会遇到问题，因为

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

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

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

选项显式“强制变量声明”
Public Sub AddNewWorkbook（）'Sub和newWB具有相同的名称（没有良好的实践）
“Dim myWksht As String”未使用，因此可以删除
将新WB设置为工作簿
“Dim MyBook As工作簿”未使用，因此可以删除
'尺寸i为整数，j为整数
Dim i As Long，j As Long’尽可能使用Long而不是整数
”“看到了吗https://stackoverflow.com/a/26409520/3219613
变暗最后一行为长，总计行为长
“Dim path1，path2 As String”始终为每个变量指定一种类型
Dim DestinationPath作为字符串“我们只需要一条路径
DestinationPath=ThisWorkbook.Path&“\Tru\Sq”
“path2=path1&“\Tru\Sq\”可以减少为一条路径
Set newWB=工作簿。添加
使用此工作簿。工作表（“数据透视表”）
LastRow=.Cells（.Rows.Count，“A”）.End（xlUp）.Row
以
使用新的工作表（“表1”）
.Name=“数据透视表”
j=.Cells（.Rows.Count，“A”）.End（xlUp）.Row+1
以
“With worksheet”（“Pivottabelle”）”不需要With（根本不使用）
“对于i=1到最后一行”不必要的循环
此工作簿.Sheets（“数据透视表”）.范围（“A1:Y400”）.副本
newWB.Sheets（“数据透视表”）.PasteSpecial
“接下来我
"以
使用newWB.工作表（“数据透视表”）
totalrows=.Cells（.Rows.Count，“A”）.End（xlUp）.Row
对于i=totalrows到2步骤-1
如果.Cells（i，8）.值为“TRU”，则
.Cells（i，8）.EntireRow.Delete'缺少一个。在单元格（i，8）之前.EntireRow.Delete
如果结束
下一个
newWB.SaveAs Filename:=DestinationPath&“Filename”&“.xlsx”缺少文件名
以
端接头

文件名解析为什么？浏览一下您的代码，您的文件似乎没有包含名称，因此您将尝试保存到类似于

ThisWorkbook.Path\Tru\Sq\.xlsx的文件，该文件无效。Filename
解析为什么？更改后的名称是否有效？请注意：对于Dim i为整数，j为整数，请使用Long
而不是Integer
。Excel的行数超过Integer可以处理的行数。您可能缺少一个