Excel VBA zpaisywanie arkuszy jako nowy skoroszyt

Odpowiedz Nowy wątek
2018-11-23 12:37
piotrek
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

Pozostało 580 znaków

2019-01-08 21:20
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

Pozostało 580 znaków

Odpowiedz
Liczba odpowiedzi na stronę

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