Pomozte mi sloučit data z více sešitů. Přikládám přílohy.* Vyřešeno

[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

[Reklama]

[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

[Dodov]

Díky funguje to paradně

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

[Branscombe]

V příloze najdeš soubor s tlačítkem z ovládacích prvků formuláře...

[Dodov]

Díky, už vidím kde jsem dělal chybu, vkládal jsem tlačítko z ovládacích prvku ActiveX

[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

[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

[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

[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