Excel
Napsal: 24 zář 2008 11:04
Poradí někdo makro nebo jiný postup jak zautomatizovat, aby se do jednoho excelovského souboru kopírovaly listy z jiných souborů.
Předem moc děkuji
Předem moc děkuji
Kód: Vybrat vše
Option Explicit
Dim OK As Boolean
Dim SesitData As Workbook, ListData As Worksheet
Sub Aktualizovat()
Dim List As Worksheet, Sesit As Workbook, Cesta As String
Dim Soubor, SouborList, i As Integer
Set Sesit = ActiveWorkbook
Cesta = "D:\data\excel\"
Soubor = Array("Soubor1.xls", "Soubor2.xls", "Soubor3.xls", "Soubor4.xls") ' seznam cest a souboru
SouborList = Array("sumář", "společné","skupina","kolektivy") ' seznam listu
'otevrit sesit a list
i = 0
Do
Set List = Sesit.Worksheets(SouborList(i))
Call OtevritSoubor(Cesta & Soubor(i), SouborList(i))
If Not OK Then Exit Sub
List.Range(ListData.UsedRange.Address).Value = ListData.UsedRange.Value
SesitData.Close
i = i + 1
Loop While i < 4
End Sub
Sub OtevritSoubor(ByVal CestaSoubor As String, ByVal List As String)
Dim MsgTit As String, MsgResponse As String
MsgTit = "Nacist"
On Error GoTo Err1
Set SesitData = Workbooks.Open(CestaSoubor)
On Error GoTo Err2
Set ListData = SesitData.Worksheets(List)
On Error GoTo 0
OK = True
Exit Sub
Err1:
MsgResponse = MsgBox("Soubor " & CestaSoubor & " nelze nalézt," & vbCrLf _
& " zkontrolujte jeho název a umístìní v adresáøi!", vbOKOnly + vbCritical, MsgTit)
OK = False
Exit Sub
Err2:
MsgResponse = MsgBox("List " & List & " v souboru " & CestaSoubor & vbCrLf _
& " nelze nalézt, zkontrolujte jeho název!", vbOKOnly + vbCritical, MsgTit)
SesitData.Close
OK = False
End Sub