Kategorie szkoleń | Egzaminy | Kontakt
  • 2
  • 0
  • 1

Mamy następująca sytuację:

Katalog: e:\osp

w katalogu: 150 plików xlsx

w każdym pliku karta o takiej samej nazwie "Opis"

Zadanie do zrobienia:

Plik zbiorczy, do którego muszą być skopiowane wszystkie karty "Opis" z zachowaniem formatowania i wyglądu.

Proszę o pomoc w stworzeniu takiego makra.

Dziękuję za pomoc.

Robert_Waliszewski_utsw
  • Zapytał
  • @ Robert_Waliszewski_utsw | 19.12.2019
    • 0
    • 0
    • 0

Odpowiedzi (2)

  • 1

W VBA można to zrobić np. tak:

Sub import()
Dim folder$, arkusz$, akt As Worksheet, ostKom As Range, off As Byte, plik$, zr As Worksheet

folder = "e:\osp\"
arkusz = "Opis"

Set akt = ActiveSheet
Set ostKom = akt.Cells(akt.Rows.Count, 1).End(xlUp)

If ostKom.Row = 1 Then
   off = 0
Else
   off = 1
   Set ostKom = ostKom.Offset(1)
End If

plik = Dir(folder)

Application.ScreenUpdating = False

Do While plik <> ""
   With Workbooks.Open(folder & plik)
      On Error Resume Next
      Set zr = .Worksheets(arkusz)
      On Error GoTo 0
      
      If Not zr Is Nothing Then zr.UsedRange.Offset(off).Copy Destination:=ostKom
      .Close savechanges:=False
   End With
   
   Set zr = Nothing
   Set ostKom = akt.Cells(akt.Rows.Count, 1).End(xlUp).Offset(1, 0)
   plik = Dir
   off = 1
Loop

Application.ScreenUpdating = True

End Sub

Proponowałbym jednak przyjrzeć się dodatkowi Power Query, w którym w podstawowej wersji w zasadzie wystarczy wskazać folder, opcjonalnie odfiltrować potrzebne pliki (np. po rozszerzeniu xlsx i wspólnej części nazwy) i rozwinąć kolumnę z danymi (kliknięciem na ikonę przy nazwie kolumny) - wszystko do łatwego wyklikania z menu. Dużo łatwiej tu o pełną kontrolę tego, co skrypt robi na każdym kroku, nawet osobie nieznającej tego narzędzia. Poniżej gotowy kod (trochę zmodyfikowana wersja tego, co PQ tworzy automatycznie):

let
    folder = "e:\osp\",
    arkusz = "Opis",
    Źródło = Folder.Files(folder),
    #"Przefiltrowano wiersze" = Table.SelectRows(Źródło, each [Folder Path] = folder and [Extension] = ".xlsx"),
    #"Dodano kolumnę wrkbk" = Table.AddColumn(#"Przefiltrowano wiersze", "wrkbk", each Excel.Workbook([Content])),
    #"Dodano kolumnę sht" = Table.AddColumn(#"Dodano kolumnę wrkbk", "sht", each try Table.SelectRows([wrkbk], each [Name]=arkusz)[Data]{0} otherwise null),
    #"Usunięto inne kolumny" = Table.SelectColumns(#"Dodano kolumnę sht",{"sht"}),
    #"Odfiltrowano wiersze" = Table.SelectRows(#"Usunięto inne kolumny", each [sht] <> null),
    #"Zamieniono wartość" = Table.ReplaceValue(#"Odfiltrowano wiersze",each [sht],each Table.PromoteHeaders([sht]),Replacer.ReplaceValue,{"sht"}),
    kolumny = Table.ColumnNames(#"Zamieniono wartość"[sht]{0}),
    #"Rozwinięty element sht" = Table.ExpandTableColumn(#"Zamieniono wartość", "sht", kolumny)
in
    #"Rozwinięty element sht"

 

 
Mirosław_Janiak
  • Odpowiedział
  • @ Mirosław_Janiak | 19.12.2019
    • 1
    • 7
    • 1
  • 0

Dziękuję bardzo.

W moim przypadku PQ nie zadziała, ponieważ w kartach są scalone pola w różnych miejscach i ich nie zachowam, a to jest dla mnie niezbędne.

Nie działa. :(

Wywala się na: " .Close savechanges:=False" jeśli jest w katalogu plik bez tej karty.

Jak usunę plik bez tej karty, to coś się dzieje, ale nie widać efektu.

Robert_Waliszewski_utsw
  • Odpowiedział
  • @ Robert_Waliszewski_utsw | 20.12.2019
    • 0
    • 0
    • 0
Komentarze
Niestety nie jestem w stanie odtworzyć Twojego błędu, u mnie makro działa zgodnie z założeniem. Może w tym katalogu masz jakieś pliki, które nie są xlsx-ami (bo w sumie takiej możliwości nie zabezpieczyłem)? Wstaw po wierszu "Do While" polecenie "Debug.Print plik" i po błędzie zobacz w oknie "Immediate" (ctrl+G), jaki plik jest ostatni na liście - to on spowodował błąd. Tu podstawowe pytanie: co to za błąd? Nie bardzo widzę możliwość, żeby chodziło wyłącznie o brak odpowiedniego arkusza, ponieważ to akurat obwarowałem funkcjami "On Error" i następującym po nich "Ifem" - jeżeli arkusza nie ma, to skoroszyt się po prostu zamknie, makro nic z nim nie będzie robić.

Możesz też spróbować usunąć (lub zakomentować apostrofem) sam parametr SaveChanges:=False, być może on w tym konkretnym momencie nie powinien wystąpić (choć w sumie i tak jest na wyrost, makro nie edytuje otwieranego pliku).

Co do braku efektów - znów SOA#1, u mnie działa. Możliwe, że problemem jest jakiś specyficzny układ danych w źródłach, ale bez poglądowego pliku niczego ciekawego nie wymyślę.
Skomentował : @ Mirosław_Janiak ,20.12.2019
  • 1
  • 7
  • 1