Scalacz – aplikacja do automatycznej konsolidacji danych z wielu skoroszytów

Opublikowany przez

Tym razem nieco większa porcja kodu. Jest to w miarę kompletna aplikacja, gotowa do użycia. Wystarczy skopiować poniższy kod do modułu publicznego w Excelu (Alt+F11, Insert – Module). Aplikacja konsoliduje dane z wielu skoroszytów i zapisuje je w zbiorczym, nowo tworzonym arkuszu. Przed użyciem proszę uważnie przeczytać założenia

Public Const WERSJA As String = "Scalacz v.1.0 (Akademia-VBA.pl)"
 
' ==================================================
' ZAŁOŻENIA:
' 1. Wszystkie skoroszyty do scalenia znajdują się w jednym folderze
' 2. Nie ma tam żadnych skoroszytów przypadkowych (w tym docelowego)
' 3. Dane do scalenia są zawsze w pierwszym arkuszu i mają jednakowe kolumny
' 4. Dane do scalenia mają nagłówki
' ==================================================
 
Sub Scalaj()
    Dim Skonsolidowany As Worksheet
    Dim Plik As String
    Dim Skor As Workbook, Ark As Worksheet
    Dim Pocz As Range, Kon As Range
    Dim Naglowki As Range, Podzakres As Range, KomDocel As Range
    Dim Licznik As Long, LW As Long, LK As Long
    Dim ZakresDocel As Range, LW_Docel As Long
    Dim Folder As String
 
    Folder = WskazFolder("Wskaż folder z plikami do scalenia", "Scalaj")
    If Len(Folder) = 0 Then
        MsgBox "Nie wskazano foldera źródłowego", vbExclamation, WERSJA
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Set Skonsolidowany = Worksheets.Add()
    Plik = Dir(Folder & "*.xls")
    Do Until Len(Plik) = 0
        Licznik = Licznik + 1
        Application.StatusBar = "Konsolidacja pliku nr " & Licznik
        Set Skor = Workbooks.Open(Folder & Plik)
        Set Ark = Skor.Sheets(1)
        If Licznik = 1 Then
            Set Naglowki = Ark.Range("A1").CurrentRegion.Rows(1)
            Naglowki.Copy Skonsolidowany.Range("A1")
            Set KomDocel = Skonsolidowany.Range("A2")
        Else
            Set ZakresDocel = Skonsolidowany.Range("A1").CurrentRegion
            LW_Docel = ZakresDocel.Rows.Count
            Set KomDocel = Skonsolidowany.Cells(LW_Docel + 1, 1)
        End If
        Set Podzakres = Ark.Range("A1").CurrentRegion
        LW = Podzakres.Rows.Count
        LK = Podzakres.Columns.Count
        Set Podzakres = Range(Ark.Range("A2"), Ark.Cells(LW, LK))
        Podzakres.Copy KomDocel
        Skor.Close False
        Plik = Dir
    Loop
    Skonsolidowany.Name = "Skonsolidowany" & StempelCzasowy
    Skonsolidowany.UsedRange.EntireColumn.AutoFit
    Skonsolidowany.Range("A1").Select
    'Application.StatusBar = "Gotowy"
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox "Konsolidacja " & Licznik & " arkuszy zakończona", vbInformation, WERSJA
End Sub
 
Function StempelCzasowy() As String
    StempelCzasowy = Format(Now(), "_yyyymmdd_hhmmss")
End Function
 
Function WskazFolder(TytulOkna As String, TytulPrzycisku As String) As String
    Dim Okno As FileDialog
    Dim Wybrane As String
    Set Okno = Application.FileDialog(msoFileDialogFolderPicker)
    Okno.Title = TytulOkna
    Okno.ButtonName = TytulPrzycisku
    If Okno.Show = -1 Then
        Wybrane = Okno.SelectedItems(1)
        If Right(Wybrane, 1) <> "\" Then
            WskazFolder = Wybrane & "\"
        Else
            WskazFolder = Wybrane
        End If
    End If
End Function

71 komentarz do “Scalacz – aplikacja do automatycznej konsolidacji danych z wielu skoroszytów”

  1. Hej

    IMHO tam jest jeszcze jedno założenie, choć niesformułowane wprost – że mianowicie dane (a ściślej – nagłówki) zaczynają się od komórki A1.

    Odpowiedz ↓

  3. Super !!! o to mi chodziło!! nie znam VBA i ta aplikacja pozowliła mi zaoszczędzić dużo pracy przy łączeniu kilkudziesięciu plików metodą kopiuj/wklej .
    Dziękuję za pomysł strony i za bezinteresowne pomoce.

    Odpowiedz ↓

  4. Cześć,

    Potrzebuje coś takiego tylko aby kopiowało dane miedzy skoroszytami w otwartym jednym arkuszu Excel. Wykorzystuje do tego celu nagrywanie makr ale nie umiem pominąć zakresu kopiowanych komórek.

    Odpowiedz ↓

  5. Cześć,
    Działa super.Mam jeden problem. Scalam także komórki z wartością które odwołują się do innych komórek.
    Jak zmienić poniższy kod aby kopiował mi wartości a nie formułę czyli „Paste Specjal – Value”
    …
    Podzakres.Copy KomDocel
    …

    Pozdrawiam,

    Odpowiedz ↓

    • bez formuł można przez zmienną tablicową:
      [cc lang=”VB”]
      Sub kopiowanie_tablica()
      Dim tbl() As Variant
      tbl = Selection
      Selection.Offset(0, 2) = tbl
      End Sub
      [/cc]

      Odpowiedz ↓

  6. witam serdecznie

    Czy mógłbyktoś przerobić kod alby wklejał wartości zamiast formuł.
    dokładnie mi o to samo chodzi co marcinEri
    Nie potrafię sam przerobić nie stety

    Odpowiedz ↓

  7. Witam,
    Mam pytanie, mam 5 skoroszytów jednakowych. Dostałem szablon, w który muszę skopiować zawartość tych 5 skoroszytów. Szablon niestety różni się od skoroszytów, kolumnami( zmienione nazwy i inne uszeregowanie) Do tej pory robiłem to ręcznie, teraz jest tych danych ponad 1000 pozycji w jednym skoroszycie. Jest jakiś kod, który będzie to w stanie scalić i uszeregować??
    Mail podałem proszę o pomoc….michu21[at]plusnet[dot]pl

    Przykład:
    W skoroszycie kolumna nazwana jest RASA a w nowym szablonie RASA PSA i inne miejsce zajmuje w nowym szablonie

    Odpowiedz ↓

  8. Cześć,
    po odpaleniu makra, otwiera mi pierwszy plik z katalogu w którym mam pliki do scalenia, w pliku wynikowym tworzy mi kolejny arkusz gdzie w pierwszym wierszu są skopiowane nagłówki z plików do scalenia a następnie pokazuje błąd „400”. Po wklejeniu linii

    On Error GoTo Errorcatch
    Errorcatch:
    MsgBox Err.Description

    pokazuje mi „Method 'Range’ of object '_Worksheet’ failed” I nie wiem co z tym można zrobić…

    Odpowiedz ↓

    • Prawdopodobnie któreś z założeń nie jest spełnione – proszę uważnie przeczytać
      Poza tym widzę, że kod był zmieniany, więc i tu coś może być…

      Odpowiedz ↓

  12. hej dzięki za gotowca, ale nie moge zapisać pliku scalonego, pojawia sie błąd: Podpis problemu:

    Nazwa zdarzenia problemu: APPCRASH
    Nazwa aplikacji: EXCEL.EXE
    Wersja aplikacji: 12.0.4518.1014
    Sygnatura czasowa aplikacji: 45428263
    Nazwa modułu z błędem: unknown
    Wersja modułu z błędem: 0.0.0.0
    Sygnatura czasowa modułu z błędem: 00000000
    Kod wyjątku: c0000005
    Przesunięcie wyjątku: 00000002
    Wersja systemu operacyjnego: 6.1.7600.2.0.0.256.1
    Identyfikator ustawień regionalnych: 1045

    Dodatkowe informacje o problemie:
    LCID: 1033
    Brand: Office12Crash
    skulcid: 1033

    wiecie może czemu?

    Odpowiedz ↓

  13. Czy można prosić o modyfikację:
    dodawanie nazwy pliku, który został dodany aby każdy wiersz był identyfikowany nazwa pliku.

    Dziękuję i pozdrawiam
    Jerzy

    Odpowiedz ↓

  15. Witam,

    Równiez prosilbym o modyfikacje: identyfikacja danych ze scalonych exceli po zaciaganej autoamtycznie nazwie pliku (w osobnej kolumnie).

    Z gory dziekuje i pozdrawiam,
    Michal

    Odpowiedz ↓

  16. Public Const WERSJA As String = „Scalacz v.1.1”

    ’ ==================================================
    ’ ZAŁOŻENIA:
    ’ 1. Wszystkie wbkInoszyty do scalenia znajdują się w jednym folderze
    ’ 2. Nie ma tam żadnych wbkInoszytów przypadkowych (w tym docelowego)
    ’ 3. Dane do scalenia są zawsze w pierwszym wshInuszu i mają jednakowe kolumny
    ’ 4. Dane do scalenia mają nagłówki
    ’ ==================================================

    Sub Scalaj()
    Dim wshDestination As Worksheet
    Dim FileNameIn As String
    Dim wbkIn As Workbook, wshIn As Worksheet, wbkOut As Workbook
    Dim Pocz As Range, Kon As Range
    Dim Headers As Range, SubRange As Range, DestCell As Range
    Dim Licznik As Long, LW As Long, LK As Long
    Dim DestRange As Range, hdrStart As Range, dataStart As Range, LW_Docel As Long
    Dim Folder As String
    Dim rowNr As Long

    Folder = WskazFolder(„Wskaż folder z FileNameInami do scalenia”, „Scalaj”)
    If Len(Folder) = 0 Then
    MsgBox „Nie wskazano foldera źródłowego”, vbExclamation, WERSJA
    Exit Sub
    End If
    Application.ScreenUpdating = False
    Set wbkOut = Workbooks.Add
    Set wshDestination = wbkOut.Sheets(1)
    FileNameIn = Dir(Folder & „*.xls”)
    Do Until Len(FileNameIn) = 0
    If FileNameIn = ThisWorkbook.Name Then GoTo Scalaj_DoUntil_End
    Licznik = Licznik + 1
    Application.StatusBar = „Konsolidacja FileNameInu nr ” & Licznik
    Set wbkIn = Workbooks.Open(Folder & FileNameIn)
    Set wshIn = wbkIn.Sheets(1)
    If wshIn.Cells(1, 2).Text „” Then
    Set hdrStart = wshIn.Cells(1, 1)
    ElseIf wshIn.Cells(2, 2).Text „” Then
    Set hdrStart = wshIn.Cells(2, 1)
    ElseIf wshIn.Cells(3, 2).Text „” Then
    Set hdrStart = wshIn.Cells(3, 1)
    Else
    MsgBox „Nie znaleziono nagłówka..”
    GoTo Scalaj_DoUntil_End
    End If
    Set dataStart = wshIn.Cells(hdrStart.Row + 1, hdrStart.Column)
    wshDestination.Activate
    If Licznik = 1 Then
    Set Headers = Range(hdrStart, hdrStart.End(xlToRight))
    Headers.Copy wshDestination.Range(„A1”)
    Set DestCell = wshDestination.Range(„A2”)
    Else
    Set DestRange = wshDestination.Range(„A1”).CurrentRegion
    LW_Docel = DestRange.Rows.Count
    Set DestCell = wshDestination.Cells(LW_Docel + 1, 1)
    End If
    Set SubRange = hdrStart.CurrentRegion
    LW = SubRange.Rows.Count
    LK = SubRange.Columns.Count
    Set SubRange = Range(dataStart, wshIn.Cells(LW, LK))
    SubRange.Copy DestCell
    If Licznik = 1 Then
    wshDestination.Cells(1, LK + 1) = „Nazwa pliku”
    End If

    wbkIn.Close False
    rowNr = DestCell.Row
    While wshDestination.Cells(rowNr, 1) „”
    wshDestination.Cells(rowNr, LK + 1) = FileNameIn
    rowNr = rowNr + 1
    Wend
    Scalaj_DoUntil_End:
    FileNameIn = Dir
    Loop
    wshDestination.Name = „Scalone_” & StempelCzasowy
    wshDestination.UsedRange.EntireColumn.AutoFit
    wshDestination.Range(„A1”).Select
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox „Konsolidacja ” & Licznik & ” plików zakończona”, vbInformation, WERSJA
    End Sub

    Function StempelCzasowy() As String
    StempelCzasowy = Format(Now(), „_yyyymmdd_hhmmss”)
    End Function

    Function WskazFolder(TytulOkna As String, TytulPrzycisku As String) As String
    Dim Okno As FileDialog
    Dim Wybrane As String
    Set Okno = Application.FileDialog(msoFileDialogFolderPicker)
    Okno.Title = TytulOkna
    Okno.ButtonName = TytulPrzycisku
    If Okno.Show = -1 Then
    Wybrane = Okno.SelectedItems(1)
    If Right(Wybrane, 1) „\” Then
    WskazFolder = Wybrane & „\”
    Else
    WskazFolder = Wybrane
    End If
    End If
    End Function

    Odpowiedz ↓

  18. Hej!
    Świetny kod! Niestety w moich warunkach potrzeba w nim jeszcze jednej zmiany. Muszę ustawić go tak, żeby kopiował tylko dane z kolumn od A do K, poza tym wszystko tak samo.
    Czy mógłbym prosić o pomoc? Próbowałem różnych rzeczy, ale niestety za każdym razem nie działało 🙁

    Odpowiedz ↓

  19. Witam
    Świetne makro. U Mnie sprawdza się połowicznie ponieważ dane w niektórych arkuszach zaczynają się od 10 wiersza. Czy można to jakoś dodać. Tak że najpierw skonsolidowało by tak w założeniu czyli od pierwszego wiersza a poźniej od np 10 wiersza już bez arkuszy wcześniej skonsolidowanych.

    Odpowiedz ↓

  20. Witam,

    makro działa bez zarzutów, znacznie ułatwiło mi pracę. Mam jednak problem ponieważ arkusze z których dane są kopiowane są chronione hasłem a niektóre skoroszyty są na dodatek jeszcze udostępnione. Czy jest możliwość udoskonalenia makra o te parametry?

    Odpowiedz ↓

    • jeżeli zahasłowany jest plik, trzeba użyć argumentu password metody Workbooks.Open, jeżeli zabezpieczony jest arkusz – trzeba użyć metody unprotect arkusza

      Odpowiedz ↓

  21. dziękuje, dodałam jeszcze kod dotyczący udostępnionego skoroszytu, a w które miejsce mam dodać kopiowanie tablicowe?:
    Sub kopiowanie_tablica()
    Dim tbl() As Variant
    tbl = Selection
    Selection.Offset(0, 2) = tbl
    End Sub

    Odpowiedz ↓

  22. Jeśli dodam przed całym kodem jak poniżej to mam dwa kody które nie mogę podpiąć pod jeden przycisk:

    Sub kopiowanie_tablica()
    Dim tbl() As Variant
    tbl = Selection
    Selection.Offset(0, 2) = tbl
    End Sub
    Sub Scalaj()
    Dim Skonsolidowany As Worksheet
    Dim Plik As String
    Dim Skor As Workbook, Ark As Worksheet
    Dim Pocz As Range, Kon As Range
    Dim Naglowki As Range, Podzakres As Range, KomDocel As Range
    Dim Licznik As Long, LW As Long, LK As Long
    Dim ZakresDocel As Range, LW_Docel As Long
    Dim Folder As String

    Folder = WskazFolder(„Wskaż folder z plikami do scalenia”, „Scalaj”)
    If Len(Folder) = 0 Then
    MsgBox „Nie wskazano foldera źródłowego”, vbExclamation, WERSJA
    Exit Sub
    End If
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set Skonsolidowany = Worksheets.Add()
    Plik = Dir(Folder & „*.xls”)
    Do Until Len(Plik) = 0
    Licznik = Licznik + 1
    Application.StatusBar = „Konsolidacja pliku nr ” & Licznik
    Set Skor = Workbooks.Open(Folder & Plik)
    Set Ark = Skor.Sheets(7)
    Application.AskToUpdateLinks = False
    If ActiveWorkbook.MultiUserEditing Then
    Application.DisplayAlerts = False
    ActiveWorkbook.ExclusiveAccess
    Application.DisplayAlerts = False
    End If
    Ark.Unprotect Password:=”re08″
    If Licznik = 1 Then
    Set Naglowki = Ark.Range(„B3”).CurrentRegion.Rows(1)
    Naglowki.Copy Skonsolidowany.Range(„B3”)
    Set KomDocel = Skonsolidowany.Range(„B4”)
    Else
    Set ZakresDocel = Skonsolidowany.Range(„B3”).CurrentRegion
    LW_Docel = ZakresDocel.Rows.Count
    Set KomDocel = Skonsolidowany.Cells(LW_Docel + 1, 1)
    End If
    Set Podzakres = Ark.Range(„B3”).CurrentRegion
    LW = Podzakres.Rows.Count
    LK = Podzakres.Columns.Count
    Set Podzakres = Range(Ark.Range(„B4”), Ark.Cells(LW, LK))
    Podzakres.Copy KomDocel
    Skor.Close False
    Plik = Dir
    Loop
    Skonsolidowany.Name = „Skonsolidowany” & StempelCzasowy
    Skonsolidowany.UsedRange.EntireColumn.AutoFit
    Skonsolidowany.Range(„B3”).Select
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox „Konsolidacja ” & Licznik & ” arkuszy zakończona”, vbInformation, WERSJA
    End Sub

    Function StempelCzasowy() As String
    StempelCzasowy = Format(Now(), „_yyyymmdd_hhmmss”)
    End Function

    Function WskazFolder(TytulOkna As String, TytulPrzycisku As String) As String
    Dim Okno As FileDialog
    Dim Wybrane As String
    Set Okno = Application.FileDialog(msoFileDialogFolderPicker)
    Okno.Title = TytulOkna
    Okno.ButtonName = TytulPrzycisku
    If Okno.Show = -1 Then
    Wybrane = Okno.SelectedItems(1)
    If Right(Wybrane, 1) „\” Then
    WskazFolder = Wybrane & „\”
    Else
    WskazFolder = Wybrane
    End If
    End If
    End Function

    Odpowiedz ↓

  25. Witam, świetne makro
    Potrzebuję jednak jednej modyfikacji, u mnie wiersze z nagłówkami zaczynają się np:od 3 wiersza,
    Chciałbym zeby makro ignorowało powiedzmy 3 pierwsze wiersze. Gdzie i co trzeba zmodyfikować ?

    Odpowiedz ↓

  27. Witam a jak w zmiennych obiektowych dodać żeby czyściło filtry w plikach czyli .ShowAllData

    sory za podwójny ale podałem złego maila

    Odpowiedz ↓

    • Wystarczy użyć metody Autofilter, która włącza/wyłącza autofiltr:
      DowolnyObiektRange.Autofilter
      np:
      ActiveCell.CurrentRegion.AutoFilter
      lub
      Selection.AutoFilter
      lub
      Zakres.Autofilter
      gdzie Zakres to oczywiście zmienna typu Range

      Odpowiedz ↓

  28. Hej! A jak zrobić żeby kopiowało również przecinki? otóż mam np nazwę ulicy która w pliku csv jest wpisana błędnie (tzn zamiast J. Kazimierza jest J, Kazimierza)- wtedy kopiuje tylko do znaku „,” a reszte (czyli następne kolumny) pomija. Da się to jakoś obejść?

    Odpowiedz ↓

  31. Witam,
    po pierwsze dzięki za makro – działa super, co prawda źle importuje csv (Excel nie radzi sobie z „;”) ale jak się zamieni rozszerzenie plików na txt i w kodzie „xls” na „txt” to już jest ekstra
    Mam pytanie do tego kodu, które ma dopisywać nazwy pliku do ostatniej kolumny (KOMENTARZ- MICHAL z22 maja 2015 @ 12:13) jest wrzucony ze złymi apostrofami i jak wklejam do excela to nie działa (czerwone podświetlenia błędnych linii). Próbowałem sam poprawiać ale coś mi nie wychodzi – czy mogę prosić jeszcze raz o jego wrzucenie? Wielkie dzięki 🙂

    Odpowiedz ↓

  32. Cześć, mam nadzieje że ktoś to jeszcze czyta 🙂 , mam pytanie , jak zmienić kod aby korzystał z arkusza 2 i zaczynał od wiersza 7 , robiłem wiele kombinacji ale niestety efekt mnie cały czas niezadowala. Dzięki za info zwrotne.

    Odpowiedz ↓

  35. Witam,
    makro super działa, mam jedno pytanie jak można zmodyfikować makro aby pobierał pliki z podfolderów. Założenie nie każdy powinien mieć dostęp do jednego podfolderu z wszystkimi plikami.
    chodzi o dołożenie pętli aby sprawdzał podfoldery w ramach wybranego podfolderu.
    Będę wdzięczny za pomoc.

    Odpowiedz ↓

  36. uzupełniając.mam 20 podfolderów w których jest różna liczba plików xls i z których to podfolderów z n plików excel z podfolderów muszę zebrać dane z pierwszego wiersza w jeden plik zbiorczy.

    Odpowiedz ↓

    • Najprościej chyba będzie dołożyć pętlę po liście folderów umieszczonych w jakimś arkuszu w aplikacji, i dla każdego foldera wykonać kod scalacza

      Odpowiedz ↓

  37. Ale pytanie w którym miejscu Pana kodu to zrobić – nie mam jeszcze tyle umiejętności w VBA – wydaje się, że być może warto zrobić to formie odrębnej procedury/modułu „sprawdzanie podfolderów” i wywoływać jako całą procedurę kod Scalacza po zajrzeniu „Scalacz” również jako moduł i aż do momentu gdy nie znajdzie. Może pokusiłby się Pan o wersję 1.2 scalacza uwzględniającą zaglądanie do plików excel w podfolderach? Będę wdzięczny za pomoc.
    Znalazłem na Akademii Altkom taką procedurę ale nie wiadomo co jest parametrem. Czy mógłbym liczyć na nową wersję scalacza zaglądającego do podkatalogów?
    Pozdrawiam Sławek
    Link do wątku
    https://quorum.akademiq.pl/discussion/1811/kopiowanielaczenie-danych-z-wielu-arkuszy-do-jednego-glownego/p1

    Private Sub PrintFolders()
    Dim sciezkaFolderu As String
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objSubFolder As Object
    Set objFSO = CreateObject(“Scripting.FileSystemObject”)
    ’ Folder do przeglądania
    Set objFolder = objFSO.GetFolder(“D:\RiskRegister”)
    Dim i As Long
    Dim j As Long
    i = 1
    j = 1
    ’ Przegląd folderów we wskazanym folderze głównym
    Application.EnableCancelKey = xlErrorHandler
    For Each objSubFolder In objFolder.subfolders
    Application.StatusBar = objSubFolder.Path & “ ” & objSubFolder.Name
    ’ Nazwa folderu
    Cells(i + 1, 1) = objSubFolder.Name
    ’ Ścieżka folderu
    sciezkaFolderu = objSubFolder.Path
    Cells(i + 1, 2) = sciezkaFolderu
    ’ Przegląd plików w folderze
    ChDir sciezkaFolderu
    j = i + 1
    Dim sciezka As String
    sciezka = Dir(„”)
    Do Until sciezka = „”
    j = j + 1
    Cells(j, 1).Value = sciezka
    Cells(j, 2).Value = sciezkaFolderu & „\” & sciezka
    sciezka = Dir
    Loop
    i = j – 1
    i = i + 1
    Next objSubFolder
    End Sub

    Odpowiedz ↓

    • Ta procedura jest do rekurencji, przy nieznanej liczbie folderów i podfolderów
      Pan zna listę swoich folderów, więc trzeba w jakimś arkuszu tą listę umieścić a potem w pętli pobierać kolejne foldery, przekazując je jako parametr do mojego kodu Scalacza
      Ta strona to reklama moich usług, które normalnie są płatne. Jeżeli jest Pan zainteresowany to proszę o maila podanego na stronie kontakt

      Odpowiedz ↓

  42. Czy można prosić o poszerzenie kodu „scalacza” tak aby potrafił połączyć kilka plików xls (xlsx), zawierających więcej niż jeden arkusz w jeden plik? Dla przykładu mamy takie same pliki xls a w każdym np. po 8 arkuszy różniących się tylko ilością kolumn (np. arusz nr 1 ma zawsze 5 kolumn, arkusz nr 2 zawsze 4 kolumny itp.). Plik wynikowy po scaleniu powinien zawierać 8 arkuszy a w nich scalone dane z poszczególnych arkuszy plików jednostkowych.

    Odpowiedz ↓

    • prawdopodobnie zamiast linijki

      Set Podzakres = Range(Ark.Range("A2"), Ark.Cells(LW, LK))
      wystarczy wpisać
      Set Podzakres = Ark.Range("A2:H10")
      oczywiście 10 to liczba kolumn którą trzeba dopasaować do swojego zakresu

      Odpowiedz ↓

  44. Witam,
    Czy istnieje możliwość, żeby kod wchodził do danego arkusza. W każdym pliku o takiej samej nazwie a nastepnie z niego kopiował dane do jednego skonsolidowanego pliku?

    Odpowiedz ↓

  45. Dziękuje, bardzo pomogło :). Nie widze w kodzie opcji paste. Czy mógłbym wkleic wszystko jako wartości?
    używając PasteSpecial Paste:=xlPasteValues?

    Odpowiedz ↓

  46. Pod Podzakres.Copy KomDocel
    Skor.Close False
    Miedzy te wiersze muszę wstawić. Kasujac KomDocel w pierwszym?
    KomDoce.PasteSpecial = xlPasteValue?

    Podzakres.Copy
    KomDoce.PasteSpecial = xlPasteValue
    Skor.Close False
    ?
    Próbowałem również odwołania do arkusza „Skonsolidowany”
    Jednak i to nie dało rezultatu.
    Dziekuje bardzo za pomoc.

    Odpowiedz ↓

  48. Koledzy,

    Uzywam funkcji kopiowania z sheeta o konkretnej nazwie.
    Moje pytanie – jak zrobic, zeby w momencie gdy nie znajduje sheeta o takiej nazwie jaka chce pomijal ten plik i wykonywal operacje dla nastepnego… ???

    Wyglada to tak:

    Sub Scalaj()
    Dim Skonsolidowany As Worksheet
    Dim Plik As String
    Dim Skor As Workbook, Ark As Worksheet
    Dim Pocz As Range, Kon As Range
    Dim Naglowki As Range, Podzakres As Range, KomDocel As Range
    Dim Licznik As Long, LW As Long, LK As Long
    Dim ZakresDocel As Range, LW_Docel As Long
    Dim Folder As String

    Folder = WskazFolder(„Wskaz folder z plikami do scalenia”, „Scalaj”)
    If Len(Folder) = 0 Then
    MsgBox „Folder zrodlowy nie zostal wskazany”, vbExclamation, WERSJA
    Exit Sub
    End If
    Application.ScreenUpdating = False
    Set Skonsolidowany = Worksheets.Add()
    Plik = Dir(Folder & „*.xlsx”)
    Do Until Len(Plik) = 0
    Licznik = Licznik + 1
    Application.StatusBar = „Konsolidacja pliku nr ” & Licznik
    Set Skor = Workbooks.Open(Folder & Plik)
    Set Ark = Skor.Sheets(„Cust_Late_Trades”)
    Range(„A1”).Select
    If Licznik = 1 Then
    Set Naglowki = Ark.Range(„A1”).CurrentRegion.Rows(1)
    Naglowki.Copy Skonsolidowany.Range(„A1”)
    Set KomDocel = Skonsolidowany.Range(„A2”)
    Else
    Set ZakresDocel = Skonsolidowany.Range(„A1”).CurrentRegion
    LW_Docel = ZakresDocel.Rows.Count
    Set KomDocel = Skonsolidowany.Cells(LW_Docel + 1, 1)
    End If
    Set Podzakres = Ark.Range(„A1”).CurrentRegion
    LW = Podzakres.Rows.Count
    LK = Podzakres.Columns.Count
    Set Podzakres = Range(Ark.Range(„A2”), Ark.Cells(LW, LK))
    Podzakres.Copy KomDocel
    Skor.Close False
    Plik = Dir
    Loop
    Skonsolidowany.Name = „Skonsolidowany” & StempelCzasowy
    Skonsolidowany.UsedRange.EntireColumn.AutoFit
    Skonsolidowany.Range(„A1”).Select
    'Application.StatusBar = „Gotowy”
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox „Konsolidacja ” & Licznik & ” arkuszy zakonczona”, vbInformation, WERSJA
    End Sub

    Function StempelCzasowy() As String
    StempelCzasowy = Format(Now(), „_yyyymmdd_hhmmss”)
    End Function

    Function WskazFolder(TytulOkna As String, TytulPrzycisku As String) As String
    Dim Okno As FileDialog
    Dim Wybrane As String
    Set Okno = Application.FileDialog(msoFileDialogFolderPicker)
    Okno.Title = TytulOkna
    Okno.ButtonName = TytulPrzycisku
    If Okno.Show = -1 Then
    Wybrane = Okno.SelectedItems(1)
    If Right(Wybrane, 1) „\” Then
    WskazFolder = Wybrane & „\”
    Else
    WskazFolder = Wybrane
    End If
    End If
    End Function

    Odpowiedz ↓

    • Można napisać funkcję logiczną sprawdzającą czy dany arkusz istnieje (for each Ark in Worksheets…)
      Nazwać ją np JestArkusz(NazwaArkuszaDoSprawdzenia)
      I dopisać na całości if JestArkusz(NazwaArkuszaDoSprawdzenia) then…

      Odpowiedz ↓

  49. Mam pytanie w jaki sposób dokleić w ostatniej kolumnie nazwę pliku z którego były konsolidowane dane. Mam zestaw różnych arkuszy z nazwami departamentów i do dalszej analizy potrzebuję informacji z jakiego departamentu pochodzą dane. Z góry bardzo dziękuję za odpowiedź.

    Odpowiedz ↓

  50. Cześć, mam bardzo proste pytanie choć dla mnie skomplikowane na samym początku. Jak wpisać kod żeby zawsze rozpoczynały scalanie od komórki A3 zamiast komórki A1 w pierwszym arkuszu ? Baardzo dziękuję za pomoc!

    Odpowiedz ↓

    • Nie wiem dokładnie jak wygląda arkusz a to może mieć znaczenie
      Na początek spróbowałbym wszystkie wystąpienia A1 zmienić na A2 a A2 na A3 🙂
      No i poczytaj inne komentarze, tam ludzie mieli podobne problemy

      Odpowiedz ↓

Dodaj komentarz

Twój adres e-mail nie zostanie opublikowany. Wymagane pola są oznaczone *