Excel: Import dat z jiných sešitů

[qi0]

Dobrý den, potřebuji makro, které z uživatelem specifikovane složky načte soubory (.xls) a zkopiruje oblast bunek na list aktivního sesitu. Každy soubor na jeden list. Myslim, že by to mělo byt jednodušši než tohle. Šlo by použit selection.copy?...Diky

Dobrý den, jak to upravit (viz.níže), aby se data importovala do aktivního sešitu na určitý list ?

Kód: Vybrat vše

Option Explicit

Sub Import()
Dim MsgResponse, MsgTit As String
Dim ImportFirstFile As Boolean, ImportDir As String, ImportFile As String
Dim ZdrojSoubor As Workbook, ZdrojList As Worksheet, ListData As String, ZdrojAdresa As String
Dim ZdrojOblast As Range, c As Range
Dim CilOblast As Range, i As Integer, j As Integer
  MsgTit = "Import dat"
  ImportFirstFile = True ' identifikace prvniho souboru v adresari
  ImportDir = "E:\excel" ' cesta k souborum
  ZdrojAdresa = "a1,b2,c3:d4,f5" ' adresy bunek se zdrojovymi daty
  Set CilOblast = ActiveWorkbook.Worksheets("list1").Range("a1")
  Application.ScreenUpdating = False
  j = 0 ' ofset radku na cilovem listu
  Do
    If ImportFirstFile Then
      ImportFile = Dir(ImportDir & "\*.xls") ' prvni soubor v adresari
      If ImportFile = "" Then _
        MsgResponse = MsgBox("Adresáø souborù: '" & ImportDir _
        & "' k importu je prázdný!", _
        vbOKOnly + vbInformation, MsgTit): Exit Do
      ImportFirstFile = False
    Else
      ImportFile = Dir ' dalsi soubory v adresari
    End If
    If ImportFile = "" Then _
      MsgResponse = MsgBox("V adresáøi souborù: '" & ImportDir _
      & "' k importu nejsou další soubory!", _
      vbOKOnly + vbInformation, MsgTit): Exit Do
      '
      MsgBox ImportFile ' pouze pro test
      '
      ListData = "list1" ' algoritmus prirazeni nazvu zdrojoveho listu dle souboru
      '
      Set ZdrojSoubor = Workbooks.Open(ImportDir & "\" & ImportFile) ' otevrit soubor
      Set ZdrojList = ZdrojSoubor.Worksheets(ListData)
      Set ZdrojOblast = ZdrojList.Range(ZdrojAdresa)
      i = 0 ' ofset sloupcu na cilovem listu
      For Each c In ZdrojOblast.Cells
        CilOblast.Offset(j, i).Value = c.Value
        i = i + 1 ' dalsi sloupec na cilovem listu
      Next c
      ZdrojSoubor.Close
      j = j + 1 ' dalsi radek na cilovem listu
  Loop ' dalsi soubor
  Application.ScreenUpdating = True
End Sub

// Vytvořeno samostatné téma.
// Příště to laskavě udělej sám a nevnucuj se do tématu, kde se řešil jiný problém a je již dávno vyřešeno. Díky!
// Mike007

[navstevnik]

to qi0:
Kdyz hovoris o zjednoduseni, zrejme mas jasnou predstavu, co lze zjednodusit, takze zjednodus, nic ti v tom nebrani.
Pokud vsak pozadujes makro, tak by bylo vhodne upresnit, co ma byt kopirovano:
- souvisla oblast nebo jednotlive bunky, z jednoho ci vice listu kazdeho sesitu?
- nazvy zdrojovych listu?
- jenom hodnoty?
- vcetne formatovani?
- nazvy cilovych listu?
- pokud kopirovat jednotlive bunky, jak je ulozit na cilovy list?
....

[qi0]

Mno tak mě napadá, že by stačilo překopirovat cely list...Názvy zdrojovych listu jsou ve všech sešitech stejné. Názvy cilovych listu změnit třeba na list1, list2...

[navstevnik]

Vzhledem k neurcitosti odpovedi je v priloze soubor takovy, jaky je.
Na listu Start uprav parametry, zavolana procedura zkopiruje ze zdrojovych souboru zadane listy do ciloveho souboru.
Pokud budes mit pocit, ze nepotrebujes mit osetreny chybove stavy, muzes si proceduru zjednodusit.

[qi0]

No to je tak nějak ono... diky. Ted se v tom budu chvili vrtat snad se mi to podaří dodelat samotnymu i když pochybuju

Každopádně kdybys měl dlouhou chvili chci se dostat k tomuto:
Uživateli se po stisknutí tlačitka zobrazí dialog oteřít... vybere jeden konkretní sešit z něhož se zkopiruje jeden uživatelem zadanej (jmeno listu) list. Dál bud zase jinym tlačitkem nebo automaticky dalsi dialog ve kterym vybere složku, ve který je x sešitů. Z každyho se zkopiruje jeden list (jmeno je pevně dany. je stejny ve vsech sesitech).
Detaily: vsechny listy zkopirovat do vychoziho sesitu. tzn ten v kterym je toto makro. Jmena listu: kromě toho prvního pojmenovat podle zdrojových sesitů. Kopirování včetně formatování.

Zatim teda dik.

[navstevnik]

Nedelam to z dlouhe chvile, ale ve snaze pomoci.
Oproti puvodnimu dotazu i odpovedi na doplnujici otazky podstatne rozsirujes pozadovane reseni.
Az se dopracujes ke konecnemu rozsahu pozadovaneho reseni a nezvladnes reseni vlastnimi silami, nekdo ti zde poradi.

[qi0]

Tak se v tom hrabu zatim to docela jde...
Kopirovani listu do vychoziho (tam kde je to makro) sesitu mam reseny takto:
ZdrojList.Copy After:=Workbooks("KopirovatListy.xls").Sheets(1)

Nešlo by to vyřešit nějak líp? Pokud nekdo tento sešit přejmenuje tak to nebude fungovat....

[navstevnik]

Deklaruj objekt workbook a na zacatku procedury prirad aktivni sesit (tedy dokud je sesit s touto procedurou aktivni) napr.:

Kód: Vybrat vše

Dim ActWbk As Workbook
...
Set ActWbk = ActiveWorkbook

a dale pak:

Kód: Vybrat vše

...
ZdrojList.Copy After:=ActWbk.Sheets(1)
....

[Jenda70]

Pro tvůj příklad mi funkce dir přijde nepraktické. Vrací string a ne objekt se všemi soubory. Já bych udělal jeden sub z tohoto VBS kodu a do druhého sub bych napsal kod co by otviral soubor po souboru a pracoval s nimi.
Jinak variant je vice:

Druhá je přes tyhle objekty VBS:
Set objFSO = CreateObject("Scripting.FileSystemObject")

(když dáš toto do googlu najdeš spoustu maker a scriptu a určitě z toho složíš co potřebuješ


' List All the Files in a Folder
sub Pro_vsechny_soubory

strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")

Set colFiles = objWMIService. _
ExecQuery("Select * from CIM_DataFile where Path = '\\Testovaci_adresar\\'")

For Each objFile in colFiles
Tvoje_procedura(objFile.Name)
Next

end sub