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

Programy pro práci v kanceláři (Word, Excel, Access…=>Office)

Moderátor: Mods_senior

EvaL
nováček
Příspěvky: 1
Registrován: říjen 18
Pohlaví: Žena

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

Příspěvekod EvaL » 16 říj 2018 13:46

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



Reklama
MePExG
Level 1.5
Level 1.5
Příspěvky: 101
Registrován: srpen 16
Pohlaví: Muž

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

Příspěvekod MePExG » 16 říj 2018 19:16


Uživatelský avatar
elninoslov
Level 2
Level 2
Příspěvky: 167
Registrován: červen 13
Pohlaví: Muž

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

Příspěvekod elninoslov » 17 říj 2018 19:41

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
Nemáte oprávnění prohlížet přiložené soubory.

MePExG
Level 1.5
Level 1.5
Příspěvky: 101
Registrován: srpen 16
Pohlaví: Muž

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

Příspěvekod MePExG » 17 říj 2018 20:34

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ť.


  • Mohlo by vás zajímat
    Odpovědi
    Zobrazení
    Poslední příspěvek
  • excel vba automaticka vyska radku sloucenych bunek
    od zutano » 20 bře 2018 10:51 » v Kancelářské balíky
    7
    710
    od atari
    22 bře 2018 10:20
  • Zapojení mnoha monitorů do PC
    od Montes » 25 lis 2018 22:10 » v Rady s výběrem hardwaru a sestavením PC
    13
    645
    od mmmartin
    30 lis 2018 15:29
  • Porovnání hodnot
    od luko02420 » 30 bře 2018 09:04 » v Kancelářské balíky
    4
    588
    od luko02420
    31 bře 2018 12:58
  • Transponování pole hodnot
    od Kurimak » 23 srp 2018 06:34 » v Kancelářské balíky
    4
    632
    od Kurimak
    24 srp 2018 08:33
  • Spojení více dokumentů do jednoho
    od kajicek94 » 27 led 2018 21:35 » v Kancelářské balíky
    9
    700
    od Hoff
    29 led 2018 11:52

Zpět na “Kancelářské balíky”

Kdo je online

Uživatelé prohlížející si toto fórum: CommonCrawl [Bot] a 0 hostů