Excel - makro

Sub LoadData()
    Dim aRange As Range
    Dim aIndex As Integer
    Dim aOpened As Boolean
    Dim aFilename As String
    Dim aWorkbook As Workbook
    
    Set aRange = Range("C3:E5")
    For aIndex = 1 To aRange.Rows.Count
        aFilename = "Vzorek " & aIndex & ".xlsx"
        On Error Resume Next
        Set aWorkbook = Workbooks(aFilename)
        On Error GoTo 0
        If aWorkbook Is Nothing Then
            Set aWorkbook = Workbooks.Open(ThisWorkbook.Path & "\" & aFilename)
            aOpened = True
        End If
        aRange.Cells(aIndex, 1).Value = aWorkbook.Worksheets("Povrch").Range("B5")
        aRange.Cells(aIndex, 2).Value = aWorkbook.Worksheets("Objem").Range("C5")
        aRange.Cells(aIndex, 3).Value = aWorkbook.Worksheets("Poloměr").Range("D5")
        If aOpened Then
            aWorkbook.Close False
            aOpened = False
        End If
        Set aWorkbook = Nothing
    Next aIndex
End Sub

Lose, moc děkuju, funguje to - neuvěřitelné!

Mě ještě napadlo...v případě, že by se ve složce kromě výše zmíněných souborů Vzorek 1-3.xlsx nacházely třeba soubory A.xlsx nebo Materiál.xlsx - dal by se ten kod ještě nějak vylepšit, aby to tahalo i data z nich?? V podstatě by stačilo, aby to tahalo data ze všech xlsx souborů ve složce (samozřejmě krom toho MASTERu). Umístění kopírovaných buňěk v těchto sešitech samozřejmě zůstává stejné.

Aby sa názvy súborov brali podľa stĺpca Vzorek, tak stači upraviť riadok:

aFilename = "Vzorek " & aIndex & ".xlsx"

na:

aFilename = aRange.Cells(aIndex, 0).Value & ".xlsx"

Dobrý den,
já bych potřeboval obdobné makro, s tím rozdílem že by vyhledávalo určité xlsx soubory v různých adresářích a obsah listu každého z nich by překopírovalo do nového souboru na jeden list pod sebe (hlavičky a sloupce jsou stejné, pouze se mění data a počty řádků).
Př. vybrat data ze souborů beh* v adresářích
c:\kurzy\20140201\beh1.xlsx
c:\kurzy\20140202\beh2.xlsx
c:\kurzy\20140203\beh3.xlsx a vložit do nového souboru c:\kurzy\2014_02\prehled.xlsx

Ještě jedna věc - V každém ze svých cca 70ti sešitů je v buňce A47 umístěn text (pokaždé jiný). Poradí někdo, jak vytvořit makro, aby se tímto textem pojmenoval název sešitu a nemusel jsem to po jednom přejmenovávat?

Děkuji.

Umiestni tento VBS skript do adresára a spusti:

Set app = CreateObject("Excel.Application")
Set fso = CreateObject("Scripting.FileSystemObject")

path = fso.GetAbsolutePathName(".")
Set folder = fso.GetFolder(path)
For Each file In folder.Files
    If LCase(fso.GetExtensionName(file.Name)) = "xlsx" Then
        Set wb = app.Workbooks.Open(path & "/" & file.Name)
        name = wb.Worksheets(1).Range("A47").Value
        wb.Close
        Set wb = Nothing
        If file.Name <> name & ".xlsx" Then
            file.Name = name & ".xlsx"
        End If
    End If
Next
app.Quit

Set app = Nothing
Set fso = Nothing

lose, nějak mi to nefunguje pro xlsm soubory (i přesto, že jsem přepsal xlsx na xlsm). Není to tím, že název listu ve které se nachází řečená buňka je PXD?

Neviem, čím to je, ale názov listu stačí predsa doplniť do tohoto riadku:

name = wb.Worksheets("PXD").Range("A47").Value