VBA - import z více sešitů do jednoho Vyřešeno

[_Stepan]

Zdravím,
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 Sub

Děkuji za pomoc a váš čas

Hezký večer

[Reklama]

[cmuch]

Trochu jsem ho poupravil

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 Long, LastRowZdrojList As Long
  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 & "\*.xlsx") ' 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")
      LastRowZdrojList = ZdrojList.Cells(ZdrojList.Rows.Count, 1).End(xlUp).Row
      On Error GoTo 0
      Set ZdrojOblast = ZdrojList.Range("A2:J" & LastRowZdrojList)
      For Each c In ZdrojOblast.Cells
      CilOblast.Offset(j, i).Value = c.Value
        If i < 9 Then
          i = i + 1 ' dalsi sloupec na cilovem listu
        Else
          i = 0
          j = j + 1 ' dalsi radek na cilovem listu
        End If
      Next c
      ZdrojSoubor.Close
      Set ZdrojSoubor = Nothing
  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 Sub

[_Stepan]

Dobré ráno,

to je přesně ono.

Děkuji!

Hezký den!