Stránka 1 z 1
Pomozte mi sloučit data z více sešitů. Přikládám přílohy.* Vyřešeno
Napsal: 08 lis 2010 18:56
od Dodov
Dobrý den,
Potřeboval bych pomocí macra sloučit data ze sešitů "data","data1","data2",.... (pokaždé jiný název souboru)
do sešitu "data konec". Pouze konkrétní buňky! Přikládám přílohy se vzorovými daty.
Udaje v souborech "data" budou vždy na teto pozici.
Děkuji za pomoc
Re: Report s více sešitů
Napsal: 09 lis 2010 00:24
od navstevnik
Nize uvedenou proceduru vloz v editoru VBA (Alt+F11) do standardniho modulu sesitu
data konec.xlsm (cilovy soubor). Uprav v procedure disk a adresar zdrojovych souboru a nazvy listu zdrojovych souboru a ciloveho souboru, pripadne vychozi bunky na zdrojovem a cilovem listu. Spustit klavesou F5 v editoru VBA. Zdrojove sesity jsou postupne otevirany a prenesena data v rozsahu poskytnuteho dema, cilovy sesit je na zaver ulozen.
Kód: Vybrat vše
Option Explicit
Sub SloucitData()
Dim MsgResponse As Byte
Dim objFSO As Object, objDir As Object, aItem As Object
Dim CntFFile As Integer, SPath As String, SFileType
Dim Swbk As Workbook, SWsht As Worksheet, SCll As Range
Dim SWshtName As String, SCllAddr As String
Dim TWbk As Workbook, TWsht As Worksheet, TCllAddr As String
Dim TCll As Range, TOffsR As Long, TWshtName As String
'*********upravit dle realu**********
SPath = "E:\Excel\dodov" ' katalog zdrojovych sesitu
SFileType = "xlsx" ' rozsireni .xlsx
' nazev listu a vychozi bunka
SWshtName = "list1" ' zdrojovych sesitu
SCllAddr = "c6"
TWshtName = "list1" ' ciloveho sesitu
TCllAddr = "c8"
'************************************
' v katalogu otevirat jednotlive soubory, prenest data
' definovat objekt FSO
Set objFSO = CreateObject("scripting.filesystemobject")
On Error Resume Next
' katalog
Set objDir = objFSO.GetFolder(SPath)
If Err.Number <> 0 Then
MsgResponse = MsgBox("Katalog zdrojových souborù nebyl nalezen." & vbCr _
& "Konec.", vbOKOnly + vbExclamation)
GoTo Err3
End If
On Error GoTo 0
' pocet souboru
CntFFile = objDir.Files.Count
' pokud CntFFile=0, zobrazi hlasku
If CntFFile > 0 Then
' definovat cilovy sesit, list, vychozi bunku, offset
Set TWbk = ThisWorkbook
Set TWsht = TWbk.Worksheets(TWshtName)
Set TCll = TWsht.Range(TCllAddr)
TOffsR = 0
' ve smycce otevirat zdrojove sesity
For Each aItem In objDir.Files
If objFSO.GetExtensionName(aItem) = SFileType Then
' definovat zdrojovy sesit, list, vychozi bunku
Set Swbk = GetObject(aItem)
Set SWsht = Swbk.Worksheets(SWshtName)
Set SCll = SWsht.Range(SCllAddr)
' prenest data
TCll.Offset(TOffsR, 0).Value = SCll.Value
TCll.Offset(TOffsR, 2).Value = SCll.Offset(1, 0).Value
TCll.Offset(TOffsR, 4).Value = SCll.Offset(2, 0).Value
Swbk.Close False ' zavrit zdrojovy sesit
Set SCll = Nothing
Set SWsht = Nothing
Set Swbk = Nothing
TOffsR = TOffsR + 1
End If
Next aItem
With Application
.DisplayAlerts = False
TWbk.Save ' ulozit cilovy sesit
.DisplayAlerts = True
End With
Else ' nebyl nalezen zadny soubor
MsgResponse = MsgBox("Katalog zdrojových souborù: '" & SPath & "' je prázdný!", _
vbOKOnly + vbInformation)
End If
Set TCll = Nothing
Set TWsht = Nothing
Set TWbk = Nothing
Err3:
Set aItem = Nothing
Set objDir = Nothing
Set objFSO = Nothing
End Sub
Re: Pomozte mi sloučit data z více sešitů. Přikládám přílohy
Napsal: 09 lis 2010 08:36
od Dodov
Díky funguje to paradně
Re: Pomozte mi sloučit data z více sešitů. Přikládám přílohy
Napsal: 10 lis 2010 08:41
od Dodov
Chtěl jsem si sám dodat do listu1 tlačítka na spuštení a smazání, ale vůbec se mi nedařilo, mohu poprosit o pomoc?
Koukal jsem do jiných maker, abych předělal do tohoto listu, ale bouzel :(
Stačilo by mi tlačítko spuštení a smazání bych si rád potom podle vzoru skusil udělat sám.
Re: Pomozte mi sloučit data z více sešitů. Přikládám přílohy
Napsal: 10 lis 2010 09:00
od Branscombe
V příloze najdeš soubor s tlačítkem z ovládacích prvků formuláře...
Re: Pomozte mi sloučit data z více sešitů. Přikládám přílohy
Napsal: 10 lis 2010 09:31
od Dodov
Díky, už vidím kde jsem dělal chybu, vkládal jsem tlačítko z ovládacích prvku ActiveX
Re: Pomozte mi sloučit data z více sešitů. Přikládám přílohy
Napsal: 10 lis 2010 09:48
od navstevnik
Ovladaci prvky z Formularu jsou pozustatkem starych verzi Excelu (<<2000) z duvodu kompatibility.
Ovladaci prvky ActiveX jsou plne programove podporovany z VBA, takze je lze jednoduse za behu programu prizpusobovat. Bohuzel je to trochu narocnejsi na znalosti, coz vede k jejich opomijeni mene zdatnymi a tvrdosijne pouzivani z Formulare..
neco na uvod:
http://www.officir.ic.cz/chipex05/07/ex ... _form.html
Re: Pomozte mi sloučit data z více sešitů. Přikládám přílohy
Napsal: 10 lis 2010 09:56
od Dodov
Jen tak pro zajímavost, jak by byl kod ve VBA pro tlačítko, který mi sem dal Branscombe? ja to včera práve skoušel pomoci prvku ActiveX a jelikož jsem v tomhle začátečník tak jsem to zkoušel opisovat z jiného macra, ale nepodařilo se mi. Někde jsem na něco zapoměl.
Si můsím sehnat nejakou učebnici
Re: Pomozte mi sloučit data z více sešitů. Přikládám přílohy
Napsal: 10 lis 2010 10:08
od navstevnik
V priloze je ukazka pouziti tlacitka z ActiveX, vyhodnoceni stisku je v modulu List1 a vykonna procedura aktivovana stiskem tlacitka je v modulu Module1
Re: Pomozte mi sloučit data z více sešitů. Přikládám přílohy
Napsal: 10 lis 2010 10:19
od Dodov
Aplikoval jsem do svýho macra a vše funguje, mám dojem, že jsem to včera měl taky takhle, ale to už ted nezjistím.
Děkuji za Vaši pomoc