mám prosbu, potřeboval bych pomoci s úpravou makra - definováním kopírované oblasti a vložení do jiného sešitu "sumáře".
Ve složce je několik zdrojových souborů (Sešit1.xlsx, Sešit2.xlsx, mají stejný formát, obsahují hlavičku). Tyto zdrojové soubory budou postupně plněny, bude se rozšiřovat oblast kopírovaných dat (po řádcích).
V přiloženém makru je vyřešeno postupné načítání souborů ve složce a import prvního řádku, potřeboval bych ho ale rozšířit tak, aby ze zdrojového souboru vybralo oblast od začátku listu (bez hlavičky, tedy sloupce A až J) k poslednímu vyplněnému řádku (stačí kontrola poslední vyplněné buňky v prvním sloupci), to stejné by provedlo s dalším souborem v dané složce, data z dalšího souboru by řadil pod data z předchozího.
Ještě by to mělo před celým importem smazání obsahu cílového listu kromě hlavičky (ale to zvládnu sám:)).
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
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 = "h:\Test_WUP\" ' cesta k souborum
Set CilOblast = ActiveWorkbook.Worksheets("list2").Range("a2")
Application.ScreenUpdating = False
j = 0 ' ofset radku na cilovem listu
Do
If ImportFirstFile Then
On Error GoTo Err0
ImportFile = Dir(ImportDir & "\*.xlsm") ' prvni soubor v adresari
On Error GoTo 0
If ImportFile = "" Then _
MsgResponse = MsgBox("Adresáo souboru: '" & 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áoi souboru: '" & ImportDir _
& "' k importu nejsou další soubory!", _
vbOKOnly + vbInformation, MsgTit): Exit Do
'
MsgBox ImportFile ' pouze pro test
'
Set ZdrojSoubor = Workbooks.Open(ImportDir & "\" & ImportFile) ' otevrit soubor
i = 0 ' ofset sloupcu na cilovem listu
On Error GoTo Err1
Set ZdrojList = ZdrojSoubor.Worksheets("list1")
On Error GoTo 0
Set ZdrojOblast = ZdrojList.Range("A2:J2")
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
Exit Sub
Err0:
MsgResponse = MsgBox("Chyba v zadání cesty a souboru '" & ImportDir & "\" & ImportFile & "'!" _
& vbCrLf & "Bih procedury bude ukoneen!", _
vbOKOnly + vbInformation, MsgTit): Exit Sub
Err1:
MsgResponse = MsgBox("V souboru " & ImportDir & "\" & ImportFile & " nebyl nalezen list1!" _
& vbCrLf & "Bih procedury bude ukoneen!", _
vbOKOnly + vbInformation, MsgTit): Exit Sub
End SubDěkuji za pomoc a váš čas
Hezký večer
