Save SPREADSHEETS in multiple excel files with the name of the main file-CodePudding

I have an Excel file with 4 auxaliary sheets 7 sheets with tables. I would like to copy and separate each sheet (of the 7 sheets) into multiple excel's, so that each excel file has only 1 table. These sheets starts with "Lista", as for example "Lista_AA", "Lista_BB"...

After I would like to save these sheets with same name they had in the main excel. I don't have code because I try with with macro recorder and didn't function.I have already looked for several videos and questions on this site and they are a little different from what I want

Sub macro()

Sheets("Lista_AA").Select
Sheets("Lista_AA").Copy
ChDir "C:\Users\marya\OneDrive - Desktop\Cantina"
ActiveWorkbook.SaveAs Filename:= _
    "https://agits-my.sharepoint.com/personal/Documents/Desktop/Cantina/Lista_AA.xlsx" _
    , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close

Sheets("Lista_BB").Select
Sheets("Lista_BB").Copy
ActiveWorkbook.SaveAs Filename:= _
 "https://agits-my.sharepoint.com/personal/Documents/Desktop/Cantina/Lista_BB.xlsx" _
    , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close

Sheets("Lista_CC").Select
Sheets("Lista_CC").Copy
ActiveWorkbook.SaveAs Filename:= _
 "https://agits-my.sharepoint.com/personal/Documents/Desktop/Cantina/Lista_CC.xlsx" _
    , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close

Sheets("Lista_DD").Select
Sheets("Lista_DD").Copy
ActiveWorkbook.SaveAs Filename:= _
 "https://agits-my.sharepoint.com/personal/Documents/Desktop/Cantina/Lista_DD.xlsx" _
    , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close

Sheets("Lista_EE").Select
Sheets("Lista_EE").Copy
ActiveWorkbook.SaveAs Filename:= _
 "https://agits-my.sharepoint.com/personal/Documents/Desktop/Cantina/Lista_EE.xlsx" _
    , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close

Sheets("Lista_FF").Select
Sheets("Lista_FF").Copy
ActiveWorkbook.SaveAs Filename:= _
  "https://agits-my.sharepoint.com/personal/Documents/Desktop/Cantina/Lista_FF.xlsx" _
    , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close

Sheets("Lista_GG").Select
Sheets("Lista_GG").Copy
ActiveWorkbook.SaveAs Filename:= _
  "https://agits-my.sharepoint.com/personal/Documents/Desktop/Cantina/Lista_GG.xlsx" _
    , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
End Sub

CodePudding user response：

Use a loop:

Const filepath As String = "https://agits-my.sharepoint.com/personal/Documents/Desktop/Cantina/"

Sub macro()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name Like "Lista_*" Then
            SaveCopy ws:=ws
        End If
    Next
End Sub

Private Sub SaveCopy(ByVal ws As Worksheet)
   ws.Copy
   Dim wb As Workbook
   Set wb = ActiveWorkbook

   wb.SaveAs FileName:=filepath & ws.Name & ".xlsx", _
             FileFormat:=xlOpenXMLWorkbook, _
             CreateBackup:=False
   wb.Close SaveChanges:=False
End Sub