Ouverture et enregistrement de nouveaux classeurs - VBA

Question

Donc, je sais qu'il y a déjà eu des questions à ce sujet, mais aucune ne semble résoudre explicitement les problèmes que j'ai. En fait, ce que j'essaie de faire est de créer un nouveau classeur, de copier et coller des données, puis de sauvegarder ce nouveau classeur sous un nouveau nom de fichier. Peu importe ce que je fais, j'ai l'impression d'avoir différents types de messages d'erreur.

Voici mon code. Toute aide est très appréciée!

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 

Il me semble que le « NEW_NAME » est à l'origine tous mes problèmes, mais je suis ouvert à tout changement qui permettra que cela fonctionne.

Merci beaucoup! Zach

ps Je suis relativement nouveau à VBA alors s'il vous plaît essayez de garder les explications un peu simples!

Answer 1

Essayez ceci:

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 

Je mets ce bloc:

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

Parce que chaque fois que la condition dans votre cas donne une réponse fausse, il va essayer de sauver les Workbooks (titi) avec le même nom "New_name.xls" et cela donnera une erreur, puisque Excel ne peut pas sauvegarder les fichiers avec le même nom.

Mais je ne suis pas sûr de ce que vous avez voulu avec cette condition Else.

Answer 2

Avec votre aide, j'ai réussi à créer quelque chose qui a fait ce que je voulais. Merci beaucoup !!!

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