VBA - zobrazení hodnot ze stejných buněk z mnoha sešitů do jednoho
VBA - zobrazení hodnot ze stejných buněk z mnoha sešitů do jednoho
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
- elninoslov
- Level 2.5
- Příspěvky: 366
- Registrován: červen 13
- Pohlaví:
- Stav:
Offline
Re: VBA - zobrazení hodnot ze stejných buněk z mnoha sešitů do jednoho
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
- Přílohy
-
- Dolovanie hodnôt zo všetkých súborov.xlsm
- (25.21 KiB) Staženo 30 x
Re: VBA - zobrazení hodnot ze stejných buněk z mnoha sešitů do jednoho
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
-
- 0
- 1513
-
od luko02420
Zobrazit poslední příspěvek
02 srp 2023 14:12
-
-
Součet hodnot s prázdnou vedlejší buňkou Příloha(y)
od Karrex » 22 kvě 2023 17:00 » v Kancelářské balíky - 7
- 1863
-
od elninoslov
Zobrazit poslední příspěvek
23 kvě 2023 22:38
-
-
- 1
- 1655
-
od atari
Zobrazit poslední příspěvek
28 dub 2023 12:08
-
-
Nastavení zabezpečení internetu zabránilo v otevření jednoho nebo více souborů Příloha(y)
od magnator » 06 čer 2023 10:23 » v Windows 11, 10, 8... - 3
- 1782
-
od mmmartin
Zobrazit poslední příspěvek
06 čer 2023 21:22
-
-
- 0
- 342
-
od Serg01
Zobrazit poslední příspěvek
02 bře 2024 16:17
Kdo je online
Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 7 hostů