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