Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
Przesunięty przez: Tajan
19-01-2023, 13:00
Zapisanie poszczególnych arkuszy jako oddzielne pliki
Autor Wiadomość
Ayala 
ExcelGaduła 500+


Wersja: Win Office 2019
Posty: 503
Wysłany: 18-01-2023, 13:43   Zapisanie poszczególnych arkuszy jako oddzielne pliki

Witam
Mam grafik pracy pracownika, który tworzy się na podstawie arkusza Dane pracownika.
Makro zapisuje mi nowego pracownika w nowym arkuszu pod nazwiskiem pracownika.
Pracowników jest 200.
Dane każdego pracownika są zaciągane do programu kadrowego.
Program jednak może zaciągać tylko z jednego arkusza i dlatego każdego pracownika należy zapisać w oddzielnym pliku z arkuszem tego pracownika.
Wygodniej byłoby zapisać wszystkich pracowników za pomocą makra do określonego katalogu (najlepiej wskazanego). Powstałoby wtedy 200 plików pod nazwą (nazwisko pracownika tak jak są nazwane arkusze na podstawie danych pracownika).
Nie wiem czy jest to w ogóle możliwe.
Będę wdzięczny za wszelkie wskazówki.
Sterowanie makrami ze wstążki Moje menu
Pozdrawiam
Ayala

Grafik 2023-01-18.xlsm
Pobierz Plik ściągnięto 8 raz(y) 265.34 KB

ID posta: 424312 Skopiuj do schowka
 
 
Ayala 
ExcelGaduła 500+


Wersja: Win Office 2019
Posty: 503
Wysłany: 18-01-2023, 14:52   

Witam
znalazłem w sieci makro, które pozwala zapisać takie pliki.
Działa, ale nie bardzo je rozumiem.
Niepotrzebnie zapisuje pliki również wyjściowe tzn. "Święta, Grafik i Dane Pracownika".
Te pliki dobrze byłoby pominąć.
Może jakaś podpowiedź
Kod:
Sub SplitWorkbook()
'Updateby20200806
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim xNWb 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

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

MkDir FolderName

For Each xWs In xWb.Worksheets
On Error GoTo NErro
    If xWs.Visible = xlSheetVisible Then
    xWs.Select
    xWs.Copy
    xFile = FolderName & "\" & xWs.Name & FileExtStr
    Set xNWb = Application.Workbooks.Item(Application.Workbooks.Count)
    xNWb.SaveAs xFile, FileFormat:=FileFormatNum
    xNWb.Close False, xFile
    End If
NErro:
    xWb.Activate
Next

    MsgBox "You can find the files in " & FolderName
    Application.ScreenUpdating = True
End Sub

Pozdrawiam

Grafik 2023-01-18.xlsm
Pobierz Plik ściągnięto 6 raz(y) 326.37 KB

ID posta: 424316 Skopiuj do schowka
 
 
Tajan


Pomógł: 5234 razy
Posty: 11412
Wysłany: 19-01-2023, 11:32   

Zamień linię:
Kod:
    If xWs.Visible = xlSheetVisible Then

na:
Kod:
    If xWs.Visible = xlSheetVisible And _
        Not (xWs.Name = "Grafik" Or _
        xWs.Name = "Dane pracowników" Or _
        xWs.Name = "Święta") Then
ID posta: 424350 Skopiuj do schowka
 
 
Ayala 
ExcelGaduła 500+


Wersja: Win Office 2019
Posty: 503
Wysłany: 19-01-2023, 11:33   

Dziękuję
ID posta: 424351 Skopiuj do schowka
 
 
Ayala 
ExcelGaduła 500+


Wersja: Win Office 2019
Posty: 503
Wysłany: 20-01-2023, 14:45   

Mam jeszcze jeden problem
W komórce L1 w arkuszach nazwisko jest zapisywane formułą z nazwy arkusza.

Kod:
=PRAWY(KOMÓRKA("nazwa_pliku";$L$1);DŁ(KOMÓRKA("nazwa_pliku";$L$1))-ZNAJDŹ("]";KOMÓRKA("nazwa_pliku";$L$1)))



Dalej zamieniam arkusze na pliki z nazwami arkuszy i tu już formuła nie działa i w komórce L1 nie mam nazwiska a błąd (makro Podziel plik).


Kod:
Sub PodzielPlik()
'Updateby20200806
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim xNWb 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

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

MkDir FolderName

For Each xWs In xWb.Worksheets
On Error GoTo NErro
    'If xWs.Visible = xlSheetVisible Then 'zapisanie wszystkich arkuszy jako pliki

    If xWs.Visible = xlSheetVisible And _
        Not (xWs.Name = "Grafik" Or _
        xWs.Name = "Dane pracowników" Or _
        xWs.Name = "Święta") Then 'zapisanie arkuszy jako pliki z wyłączeniem arkuszy "Grafik", " Dane pracowników" oraz "Święta"
   
    xWs.Select
    xWs.Copy
    xFile = FolderName & "\" & xWs.Name & FileExtStr
    Set xNWb = Application.Workbooks.Item(Application.Workbooks.Count)
    xNWb.SaveAs xFile, FileFormat:=FileFormatNum
    xNWb.Close False, xFile
    End If
NErro:
    xWb.Activate
Next

    MsgBox "You can find the files in " & FolderName
    Application.ScreenUpdating = True
   
    Call GoToGrafik
End Sub

Może jakiś pomysł.
Próbuję na różne sposoby, ale nic nie wychodzi.
Będę wdzięczny za podpowiedź.

Grafik_test.xlsm
Pobierz Plik ściągnięto 4 raz(y) 316.18 KB

ID posta: 424387 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.wip.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe