Musí to byť VBA? ..., lebo PQ to zvládne hravo.citovat
excel, návod, tipy, funkce, makra, vba, tabulky, šablony
Váš průvodce programem Microsoft Excel a programováním maker ve VBA
< návrat zpět
Téma: VBA kopírovat data z jiných sešitů
MS Excel
Téma: VBA kopírovat data z jiných sešitů 
Zaslal/a Matlock 2.2.2019 12:12
Zdravím všechny programátory, potřeboval bych pomoct s vytvořením makra, ale nevím, jestli je to možné. O co se jedná. Příklad: měl bych složku "data" a v ní hlavní sešit data.xlsm a další sešity xlsx, např. sešit1.xlsx, sešit2.xlsx, atd. Počet sešitů xlsx je různý. Potřeboval bych, aby v sešitě data.xlsm se ve sloupci A zapsal seznam všech sešitů xlsx a do sloupců B až E se na každý řádek zkopírovaly z List1 údaje z řádků B1 až E1 daného sešitu xlsx. Předem moc děkují alespoň za nějaký nápad.
Možný příklad řešení. Soubor "data" nemusí být ve stejné složce jako soubory ze kterých chceme data čerpat. Při spuštění je zobrazen dialog pro výběr sešitů.
Příloha: 
42630_wall.zip (44kB, staženo 33x)
citovat42630_wall.zip (44kB, staženo 33x)Není to úplně přesné jak jsem si představoval, ale takto mi to stačí. Děkují moccitovat
Alebo aj niečo podobné:
Sub SouhrnDat2()
Dim D() As String, Soubory() As String, Soubor As String, Cesta As String, Pocet As Long
Cesta = ThisWorkbook.Path & "\"
Soubor = Dir(Cesta & "*.xlsx", vbHidden)
While Soubor <> ""
Pocet = Pocet + 1
ReDim Preserve Soubory(1 To Pocet)
Soubory(Pocet) = Soubor
ReDim Preserve D(1 To Pocet)
D(Pocet) = "='" & Cesta & "[" & Soubor & "]List1'!B$1"
Soubor = Dir()
Wend
If Pocet > 0 Then
With List1.Cells(2, 1).Resize(Pocet)
.Value = Application.Transpose(Soubory)
With .Offset(0, 1).Resize(Pocet, 4)
.Formula = Application.Transpose(D)
.Value = .Value
End With
End With
End If
End Subcitovat
Sub SouhrnDat2()
Dim D() As String, Soubory() As String, Soubor As String, Cesta As String, Pocet As Long
Cesta = ThisWorkbook.Path & "\"
Soubor = Dir(Cesta & "*.xlsx", vbHidden)
While Soubor <> ""
Pocet = Pocet + 1
ReDim Preserve Soubory(1 To Pocet)
Soubory(Pocet) = Soubor
ReDim Preserve D(1 To Pocet)
D(Pocet) = "='" & Cesta & "[" & Soubor & "]List1'!B$1"
Soubor = Dir()
Wend
If Pocet > 0 Then
With List1.Cells(2, 1).Resize(Pocet)
.Value = Application.Transpose(Soubory)
With .Offset(0, 1).Resize(Pocet, 4)
.Formula = Application.Transpose(D)
.Value = .Value
End With
End With
End If
End Subcitovat
(3.2.2019 13:32)#042641
Tak to je přesně tak, jak jsem si to představoval. Moc děkují oběma za strávený čas. Jste pašáci. 
citovat
citovatTak to je přesně tak, jak jsem si to představoval. Moc děkují oběma za strávený čas. Jste pašáci. citovat
citovatJe viac možností. Ak by sa napríklad nevolal list v tých súboroch rovnako, dá sa cez ADO zistiť názov listu bez otvorenia súboru. Ale to už je otázka, či potom neprečítať rovno aj hodnoty cez ADO.
Ak sa ale volajú listy rovnako, tak vyššie uvedené bude asi najrýchlejšie riešenie.
PQ nezavrhujte, dajú sa tam robiť psie kusy, a zrovna mepexg je macher. Navyše nemusia byť povolené makrá (firemná fóbia).citovat
Ak sa ale volajú listy rovnako, tak vyššie uvedené bude asi najrýchlejšie riešenie.
PQ nezavrhujte, dajú sa tam robiť psie kusy, a zrovna mepexg je macher. Navyše nemusia byť povolené makrá (firemná fóbia).citovat
PQ nezavrhují, jen jsem o něm nevěděl. Takže vůbec nevím, co vše umí. A věřím tomu, že všichni, co tu nějak vypomůžou, tak jsou machři. Já před nimi jen smekám.citovat
Uživatelské menu
Nejste přihlášen(a)
\n
\nMenu
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.
RSS nejnovější články