Excel VBA zpaisywanie arkuszy jako nowy skoroszyt

0

Cześć,
Wielka prośba o pomoc przy stworzeniu/edycji kodu który pozwoli zapisać jako nowy skoroszyt zdefiniowane wcześniej grupy arkuszy z aktywnego skoroszytu.
Znalazłem w sieci rozwiązanie, które pozwala wyeksportować wszystkie wszystkie arkusze
Pozdrawiam

Sub SplitWorkbook()
'Updateby20140612
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "" & xWb.Name & " " & DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
xWs.Copy
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
Select Case xWb.FileFormat
Case 51:
FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If Application.ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56:
FileExtStr = ".xls": FileFormatNum = 56
Case Else:
FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
xFile = FolderName & "" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
Application.ActiveWorkbook.Close False
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub

0

Umieszczasz kod w skoroszycie źródłowym, w tym przypadku kod odnosi się do nazwy "FirstWorkbook.xlsm", następnie tworzy skoroszyt docelowy "SecondWorkbook.xlsx" i zapisuje w miejscu, gdzie znajduje się pierwszy. Porównuje nazwy wszystkich arkuszy z tablicą, pasujące kopiuje.

Sub CopyWorkSheets()

Dim NewSheetsNames() As Variant
Dim wb01 As Workbook
Dim wb02 As Workbook
Dim ws As Worksheet

NewSheetsNames = Array("a", "b", "c") 'tutaj wpisujesz nazwy arkuszy, które chcesz skopiować
Set wb01 = Workbooks("FirstWorkbook.xlsm") 'plik źródłowy
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=wb01.Path & Application.PathSeparator & "SecondWorkbook" & ".xlsx"
ActiveWindow.WindowState = xlMinimized
Set wb02 = Workbooks("SecondWorkbook.xlsx") 'plik docelowy


For Each ws In wb01.Worksheets
    For ArrEl = 0 To UBound(NewSheetsNames, 1)
        If ws.Name = NewSheetsNames(ArrEl) Then
            wb01.Worksheets(ws.Name).Copy After:=wb02.Worksheets(wb02.Sheets.Count)
        End If
    Next ArrEl
Next ws


Application.DisplayAlerts = False
wb02.Worksheets(1).Delete
Application.DisplayAlerts = True

End Sub

1 użytkowników online, w tym zalogowanych: 0, gości: 1