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
ID tematu: 73216 Skopiuj do schowka Podział danych na pliki
Autor Wiadomość
adrew 
Świeżak


Wersja: Mac Office 365
Posty: 1
Wysłany: 10-08-2022, 03:41   Podział danych na pliki

Witajcie

Chciałbym sobie ułatwić pracę aby nie musieć codziennie ręcznie tego filtrować, kopiować i zapisywać pod inną nazwą więc proszę o pomoc w stworzeniu automatu który to zrobi.

Mam tabelę, w drugiej kolumnie (C) jest data, chciałbym z pomocą VBA podzielić na kilka skoroszytów te dane, tak aby w każdym skoroszycie były dane z 1 dnia.
Pliki z tymi danymi niech mają daty z kolumny "C" w nazwie.
Tabela może mieć nieznaną na chwile obecną ilość kolumn, i wierszy więc fajnie jakby zakres nie był sztywno ustawiony tylko brane pod uwagę jako ostatnie były ostatnie niepuste komórki nagłówka (kolumny) i daty (wiersze)

DANE-TESTOWE.xlsx
Pobierz Plik ściągnięto 21 raz(y) 12.31 KB

ID posta: 419573 Skopiuj do schowka
 
 
dj_majk 
Excel Expert



Zaproszone osoby: 1
Wersja: Win Office 2010
Pomógł: 382 razy
Posty: 1232
Wysłany: 10-08-2022, 06:15   

adrew, proponuję ten kod:
Kod:
Sub kopiowanie()
Dim wb As Workbook
Dim ws As Worksheet
Dim wbNew As Workbook
Dim wsNew As Worksheet
Dim naglowek As Variant
Dim lr As Long
Dim lc As Long
Dim tbl As Variant
Dim tblCopy() As Variant
Dim dic As Object
Dim counter As Long
Dim i, k, j, z As Long
Dim sciezka As String

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .EnableEvents = False
End With

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Arkusz1")
   
    With ws
        lr = .Cells(.Rows.Count, 3).End(xlUp).Row
        lc = .Cells(3, .Columns.Count).End(xlToLeft).Column
        naglowek = .Range(.Cells(3, 2), .Cells(3, lc))
        tbl = .Range(.Cells(4, 2), .Cells(lr, lc))
    End With
   
    Set dic = CreateObject("scripting.dictionary")
    For i = LBound(tbl) To UBound(tbl)
        If Not dic.Exists(tbl(i, 2)) Then
            dic.Add tbl(i, 2), tbl(i, 2)
        End If
    Next
   
    With ws
        For Each el In dic.Items()
            counter = Application.CountIf(.Range("C:C"), el)
            ReDim Preserve tblCopy(1 To counter, 1 To lc - 1)
            z = 1
            j = 1
                For i = LBound(tbl, 1) To UBound(tbl, 1)
                    If tbl(i, 2) = el Then
                        For k = LBound(tblCopy, 2) To UBound(tblCopy, 2)
                            tblCopy(j, k) = tbl(i, z)
                            z = z + 1
                        Next k
                        j = j + 1
                        z = 1
                    End If
                Next i
               
                Set wbNew = Workbooks.Add
                Set wsNew = wbNew.Worksheets(1)
               
                With wsNew
                    .Name = el
                    .Cells(1, 1).Resize(UBound(naglowek, 1), UBound(naglowek, 2)) = naglowek
                    .Cells(2, 1).Resize(UBound(tblCopy, 1), UBound(tblCopy, 2)) = tblCopy
                End With
               
                sciezka = ThisWorkbook.Path
                wbNew.SaveAs sciezka & "\" & el & ".xlsx", 51
                wbNew.Close
                Erase tblCopy
        Next
    End With

    Set dic = Nothing
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
    .EnableEvents = True
End With
End Sub
_________________
Pozdrawiam
Michał
ID posta: 419575 Skopiuj do schowka
 
 
beret
ExcelGaduła 500+


Wersja: Win Office 2010
Pomógł: 22 razy
Posty: 995
Wysłany: 29-08-2022, 07:59   

Jak przerobić powyższy kod, aby nie tworzył oddzielnych plików, tylko oddzielne arkusze w tym samym pliku?
ID posta: 420089 Skopiuj do schowka
 
 
dj_majk 
Excel Expert



Zaproszone osoby: 1
Wersja: Win Office 2010
Pomógł: 382 razy
Posty: 1232
Wysłany: 29-08-2022, 09:08   

beret, ten fragment kodu:
Kod:

                Set wsNew = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
               
                With wsNew
                    .Name = el
                    .Cells(1, 1).Resize(UBound(naglowek, 1), UBound(naglowek, 2)) = naglowek
                    .Cells(2, 1).Resize(UBound(tblCopy, 1), UBound(tblCopy, 2)) = tblCopy
                End With
_________________
Pozdrawiam
Michał
ID posta: 420090 Skopiuj do schowka
 
 
beret
ExcelGaduła 500+


Wersja: Win Office 2010
Pomógł: 22 razy
Posty: 995
Wysłany: 30-08-2022, 07:50   

Zrobiłem tak i w tym miejscu kodu:
Kod:
 ReDim Preserve tblCopy(1 To counter, 1 To lc - 1)

wyrzuca błąd:

Przechwytywanie.PNG
Plik ściągnięto 136 raz(y) 3.72 KB

ID posta: 420122 Skopiuj do schowka
 
 
Tajan


Pomógł: 5091 razy
Posty: 11145
Wysłany: 30-08-2022, 13:30   

beret, kod jest poprawny. Być może uruchomiłeś go w arkuszu, który ma inny układ danych niż skoroszyt przykładowy i nie dostosowałeś kodu wyznaczającego obszar działania makra:
Kod:
    With ws
        lr = .Cells(.Rows.Count, 3).End(xlUp).Row
        lc = .Cells(3, .Columns.Count).End(xlToLeft).Column
        naglowek = .Range(.Cells(3, 2), .Cells(3, lc))
        tbl = .Range(.Cells(4, 2), .Cells(lr, lc))
    End With
ID posta: 420143 Skopiuj do schowka
 
 
beret
ExcelGaduła 500+


Wersja: Win Office 2010
Pomógł: 22 razy
Posty: 995
Wysłany: 31-08-2022, 09:04   

Załączam plik z tym kodem i z tym błędem.

DANE-TESTOWE2.xlsm
Pobierz Plik ściągnięto 9 raz(y) 24.33 KB

ID posta: 420165 Skopiuj do schowka
 
 
dj_majk 
Excel Expert



Zaproszone osoby: 1
Wersja: Win Office 2010
Pomógł: 382 razy
Posty: 1232
Wysłany: 31-08-2022, 10:00   

beret, po tym fragmencie:
Kod:
                With wsNew
                    .Name = el
                    .Cells(1, 1).Resize(UBound(naglowek, 1), UBound(naglowek, 2)) = naglowek
                    .Cells(2, 1).Resize(UBound(tblCopy, 1), UBound(tblCopy, 2)) = tblCopy
                End With

zgubiłeś:
Kod:
Erase tblCopy
_________________
Pozdrawiam
Michał
ID posta: 420167 Skopiuj do schowka
 
 
Maciej Gonet 
Excel Expert


Wersja: Win Office 365
Pomógł: 2828 razy
Posty: 8516
Wysłany: 31-08-2022, 10:28   

Można też pomiąć Preserve przy instrukcji ReDim. Ono tam jest niepotrzebne, a powoduje błąd, bo przy ReDim Preserve można zmieniać tylko ostatni indeks.
ReDim bez Preserve kasuje dotychczasową zawartość tablicy.
Dodałem też dopasowanie szerokości kolumn, bo daty się u mnie nie mieściły.

DANE-TESTOWE2_1.xlsm
Pobierz Plik ściągnięto 8 raz(y) 30.32 KB

ID posta: 420170 Skopiuj do schowka
 
 
beret
ExcelGaduła 500+


Wersja: Win Office 2010
Pomógł: 22 razy
Posty: 995
Wysłany: 31-08-2022, 15:38   

Teraz jest OK.
Dodałem jeszcze na początku usuwanie arkuszy:
Kod:
For i = ThisWorkbook.Sheets.Count To 1 Step -1     'Usuwanie arkuszy
        If Sheets(i).Name <> "Arkusz1" Then
            Sheets(i).Delete
        End If
    Next
ID posta: 420182 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