打开并保存新的工作簿 - VBA

所以我知道以前有过这方面的问题，但没有一个似乎明确地解决了我遇到的问题。实际上，我正在尝试创建一个新工作簿，将数据复制并粘贴到该工作簿中，然后将该新工作簿保存为新文件名。无论我做什么，我似乎都会收到各种类型的错误消息。打开并保存新的工作簿 - VBA

这是我的代码。任何帮助非常感谢！

Private Sub DoStuff() 

CurrentFile = "June_Files_macros_new.xlsm" 
NewFile = "Train10_June01.xls" 

Workbooks.Add 


'Save New Workbook 
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & NewFile 

For i = 2 To 55 
    If Cells(i, 3) = Cells(i - 1, 3) And Cells(i, 13) = Cells(i - 1, 13) Then 
      Workbooks(CurrentFile).Worksheets("Sheet1").Rows(i).Copy _ 
      Workbooks(NewFile).Worksheets("Sheet1").Rows(i) 
    Else: Workbooks(NewFile).SaveAs ThisWorkbook.Path & "\" & "New_Name" 
    End If  
Next i 

End Sub

在我看来，“New_Name”导致我所有的问题，但我愿意改变任何可以让它工作的东西。

非常感谢！ Zach

ps我对VBA比较新，所以请尽量保持任何解释的简单！

来源

2017-07-26 Zach Schenk

你得到了什么错误？如果你点击'Debug'，它突出显示'Else：...'行？另外，它是否正确地保存为'newFile'，而不是''New_Name“'？ – BruceWayne

试试这个：

Private Sub DoStuff() 
    Dim CurrentFile As String 
    Dim NewFile As String 
    Dim i As Long 
    Dim wb As Workbook 

    CurrentFile = "June_Files_macros_new.xlsm" 
    NewFile = "Train10_June01.xls" 

    Set wb = Workbooks.Add 
    wb.SaveAs Workbooks(CurrentFile).Path & "\" & NewFile 

    For i = 2 To 55 
     If Cells(i, 3) = Cells(i - 1, 3) And Cells(i, 13) = Cells(i - 1, 13) Then 
      Workbooks(CurrentFile).Sheets("Sheet1").Rows(i).Copy Workbooks(NewFile).Worksheets("Sheet1").Rows(i) 
     Else 
      Set wb = Workbooks(NewFile) 
      wb.SaveAs Workbooks(CurrentFile).Path & "\" & "New_name.xls" 
      Exit For 
     End If 
    Next i 

End Sub

我把这个块：

Else 
    Set wb = Workbooks(NewFile) 
    wb.SaveAs Workbooks(CurrentFile).Path & "\" & "New_name.xls" 
    Exit For

因为每次你如果条件给出错误的响应时间，它会尝试保存工作簿（NEWFILE）与同名“New_name.xls”，这会给出一个错误，因为Excel不能保存具有相同名称的文件。

但我不确定你想要这个Else条件。

来源

2017-07-26 15:09:24

这是对我的脚本的改进......但由于某些原因，它无法复制和粘贴数据。如同，我打开了Train10_June1和New_name，并且都没有任何数据。我知道for循环和if语句正在工作，因为他们之前工作... –

你需要澄清你想要什么。在代码中，对于“New_name.xls”存档，您的If-Else语句不执行任何操作，但用新名称保存Workbooks（NewFile）。如果你想复制到两个Excel文件，你需要再次检查你的If-Else语句。 –

在你的帮助下，我设法创造了一些我想做的事情。非常感谢！

Private Sub DoStuff() 

Application.DisplayAlerts = False 

'Create New Workbook 

Dim Count As Integer 

CurrentFile = "June_Files_macros_new.xlsm" 
NewFile = "Train" & CStr(Cells(2, 13)) & "_" & CStr(Cells(2, 3)) & ".xls" 

Workbooks.Add 


'Save New Workbook 
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & NewFile 

'Select top row of data and insert into spreadsheed!!!!! 
Workbooks(CurrentFile).Worksheets("Sheet1").Rows(2).Copy 
Workbooks(NewFile).Worksheets("Sheet1").Rows(2).PasteSpecial xlPasteValues 


Count = 3 



For i = 3 To 12802 

'if Date and Train Number are equal, Then copy and paste the i th row 
'else, save new file, create another new file, save 

    If Cells(i, 3) = Cells(i - 1, 3) And Cells(i, 13) = Cells(i - 1, 13) Then 
      Workbooks(CurrentFile).Worksheets("Sheet1").Rows(i).Copy 
      Workbooks(NewFile).Worksheets("Sheet1").Rows(Count).PasteSpecial xlPasteValues 
      Count = Count + 1 

    Else: Workbooks(CurrentFile).Worksheets("Sheet1").Rows(1).Copy 
      Workbooks(NewFile).Worksheets("Sheet1").Rows(1).PasteSpecial xlPasteValues 
      Workbooks(NewFile).SaveAs ThisWorkbook.Path & "\" & "Train" & CStr(Cells(i - 1, 13)) & "_" & CStr(Cells(i - 1, 3)) & ".xls" 
      Workbooks(NewFile).Close 

      Workbooks.Add 
      NewFile = "Train" & CStr(Cells(i, 13)) & "_" & CStr(Cells(i, 3)) & ".xls" 
      ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & NewFile 

      Workbooks(CurrentFile).Worksheets("Sheet1").Rows(i).Copy 
      Workbooks(NewFile).Worksheets("Sheet1").Rows(2).PasteSpecial xlPasteValues 

      Count = 3 
    End If 

Next i 

Workbooks(CurrentFile).Worksheets("Sheet1").Rows(1).Copy 
Workbooks(NewFile).Worksheets("Sheet1").Rows(1).PasteSpecial xlPasteValues 

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & NewFile 

Workbooks(NewFile).Close

来源

2017-07-27 21:15:21

打开并保存新的工作簿 - VBA

回答

相关问题