Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Podział danych na pliki

adrew · Świeżak Wersja: Mac Office 365 Posty: 1

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 27 raz(y) 12.31 KB

dj_majk · Wysłany: 10-08-2022, 07: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

beret · Wysłany: 29-08-2022, 08:59

Jak przerobić powyższy kod, aby nie tworzył oddzielnych plików, tylko oddzielne arkusze w tym samym pliku?

dj_majk · Wysłany: 29-08-2022, 10: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

beret · Wysłany: 30-08-2022, 08: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 170 raz(y) 3.72 KB

Tajan · **Pomógł:** 5234 razy Posty: 11414

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

beret · Wysłany: 31-08-2022, 10:04

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

DANE-TESTOWE2.xlsm

Pobierz Plik ściągnięto 14 raz(y) 24.33 KB

dj_majk · Wysłany: 31-08-2022, 11: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

Maciej Gonet · Wysłany: 31-08-2022, 11: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 14 raz(y) 30.32 KB

beret · Wysłany: 31-08-2022, 16: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