VBA - zobrazení hodnot ze stejných buněk z mnoha sešitů do jednoho

[EvaL]

Dobrý den, moc prosím o pomoc. Mám 11 složek, každá z nich obsahuje cca 300 excelovských souborů, jsou to faktury (všechny mají tedy stejnou strukturu). Potřebuji udělat jakousi databázi odběratelů - tedy z každé té faktury vytáhnout hodnoty 3 buněk (jméno odběratele, ulice a město) a v novém excelovském souboru udělat z těchto dat tabulku (sloupce by tedy byly 3: jméno odběratele, ulice, město a počet řádků dle počtu faktur). Moc prosím o pomoc, jak to udělat, aniž by se musely prostě kopírovat nebo přepisovat data z jedné faktury za druhou... Mělo by to jít přes VBA, ale nejsem v tom moc zběhlá, tak prosím o pomoc. Děkuji. Eva

[MePExG]

http://www.jaknaoffice.cz/2-forum/?id=4813

[elninoslov]

PowerQuery bude lepšie a univerzálnejšie, ale tu je aj návrh makra. Musí sa jednať iba o jeden list v každom súbore, a musí ten list mať rovnaký názov. Načítanie 3 hodnôt z 3300 súborov, so zoradením podľa abecedy a vyčistením duplicít trvá 27 sekúnd. Boli to náhodne generované súbory s náhodným menom a náhodným obsahom 3 buniek. Pravdepodobne ak to budú reálne zaplnené súbory bude to o pár sekúnd viac. Pomocou ADO by sa dal zisťovať aj menný zoznam listov v každom súbore bez jeho otvorenia, ale to by bolo už podstatne pomalšie pri toľkých súboroch. Skúste ešte presvedčiť MePExG-a na to PQ :)

Kód: Vybrat vše

Sub DolujData()
Dim Subory() As String, Pocet As Long, Cesta As String, Adresar As String, List As String, Subor As String, FSO As Object, oSubFolder As Object, oFile As Object, arrTmp(), y As Long, Vzorce()
Dim Bunka1 As String, Bunka2 As String, Bunka3 As String, rng As Range

    Pocet = -1
    With ThisWorkbook.ActiveSheet
        Cesta = .Cells(2, 6).Value
        Bunka1 = .Cells(6, 6).Value
        Bunka2 = .Cells(8, 6).Value
        Bunka3 = .Cells(10, 6).Value
        List = "]" & .Cells(4, 6).Value & "'!" & Bunka1
        
        .Range(.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0), .Cells(2, 3)).ClearContents
        If Right$(Cesta, 1) <> "\" Then Cesta = Cesta & "\"
        Set FSO = CreateObject("Scripting.FileSystemObject")
        
        'Získanie zoznamu súborov vo všetkých podadresároch a príprava prvého vzorca
        For Each oSubFolder In FSO.GetFolder(Cesta).subfolders
            Adresar = "='" & FSO.GetAbsolutePathName(oSubFolder) & "\["
            
            For Each oFile In oSubFolder.Files
                Subor = oFile.Name
                If InStr(1, FSO.GetExtensionName(Subor), "xls", vbTextCompare) > 0 Then
                    Pocet = Pocet + 1
                    ReDim Preserve Subory(Pocet)
                    Subory(Pocet) = Adresar & Subor & List
                End If
            Next oFile
        Next oSubFolder
    
        'Príprava a vloženie vzorcov
        If Pocet > -1 Then
            If Pocet > 0 Then Subor = Join(Subory, "$$$") Else Subor = Subory(0)
            ReDim Vzorce(1 To Pocet + 1, 1 To 1)
            
            Application.ScreenUpdating = False
            Application.EnableEvents = False
            
            Vzorce = WorksheetFunction.Transpose(Subory)
            arrTmp = Array(Split(Replace(Subor, Bunka1, Bunka2), "$$$"), Split(Replace(Subor, Bunka1, Bunka3), "$$$"))
            
            ReDim Preserve Vzorce(1 To Pocet + 1, 1 To 3)
            For y = 0 To Pocet
                Vzorce(y + 1, 2) = arrTmp(0)(y): Vzorce(y + 1, 3) = arrTmp(1)(y)
            Next y
            With .Cells(2, 1).Resize(Pocet + 1, 3)
                .Formula = Vzorce
                .Value = .Value
            End With
            
            'Zoradenie a vymazanie duplikátov
            Set rng = .Cells(2, 1).Resize(Pocet + 1, 3)
            rng.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo

            With .Sort
                With .SortFields
                    .Clear
                    .Add2 Key:=rng.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                    .Add2 Key:=rng.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                    .Add2 Key:=rng.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                End With
                .SetRange rng
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        
            Application.ScreenUpdating = True
            Application.EnableEvents = True
        End If
    End With
    
    Set oFile = Nothing: Set oSubFolder = Nothing: Set FSO = Nothing: Set rng = Nothing
End Sub

[MePExG]

Dobrý deň. Mňa nie je potrebné presviedčať, rád pomôžem ak viem, ale nemám vo zvyku si vymýšľať zdrojové súbory a okrem toho neviem či zadávateľ o moju prácu stojí resp. či by ju mohol použiť.