Nevím jak jsi zdatný, ale zkusím ti dát makro co jsem nedávno vytvořil pro načítání ze spousty souborů, akorát že po sebe. Seznam souborů byl v listu1 ve sloupci A, bylo jich cca 80 a toto makro ze všech získalo data. Ono bylo by snadné napsat konkrétní řešení, ale takhle alespoň sám zabádáš :-) a upravíš si to k obrazu svému.
Public Sub fillin()
Dim okno As String
Dim okno_tmp As String
Dim rd As Single
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
okno = ActiveWorkbook.Name
For i = 2 To List1.UsedRange.Rows.Count + 1
If List1.Cells(i, 2) <> "" Then
If Dir(ThisWorkbook.Path & "\SC\" & List1.Cells(i, 1) & "_" & List1.Cells(i, 3) & ".xls") <> "" Then
Workbooks.Open ThisWorkbook.Path & "\SC\" & List1.Cells(i, 1) & "_" & List1.Cells(i, 3) & ".xls", xlNo, xlYes
ActiveSheet.Range("A2:A" & ActiveSheet.UsedRange.Rows.Count).Copy
okno_tmp = ActiveWorkbook.Name
Workbooks(okno).Activate
List2.Activate
List2.Cells(List2.UsedRange.Rows.Count + 1, 2).Activate
rd = List2.UsedRange.Rows.Count + 1
ActiveCell.PasteSpecial xlPasteValues
List2.Range("A" & rd, "A" & List2.UsedRange.Rows.Count) = okno_tmp
Workbooks(okno_tmp).Close xlNo
End If
End If
Next
rd = 2
Do While List2.Cells(rd, 1) <> ""
If List2.Cells(rd, 2) = "Transakce" Then
List2.Rows(rd).Delete
Else
List2.Cells(rd, 2) = UCase(List2.Cells(rd, 2))
List2.Cells(rd, 3).Formula = "=left(A" & rd & ",8)&" & Chr(34) & "_" & Chr(34) & "&UPPER(B" & rd & ")"
rd = rd + 1
End If
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
M@citovat
Public Sub fillin()
Dim okno As String
Dim okno_tmp As String
Dim rd As Single
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
okno = ActiveWorkbook.Name
For i = 2 To List1.UsedRange.Rows.Count + 1
If List1.Cells(i, 2) <> "" Then
If Dir(ThisWorkbook.Path & "\SC\" & List1.Cells(i, 1) & "_" & List1.Cells(i, 3) & ".xls") <> "" Then
Workbooks.Open ThisWorkbook.Path & "\SC\" & List1.Cells(i, 1) & "_" & List1.Cells(i, 3) & ".xls", xlNo, xlYes
ActiveSheet.Range("A2:A" & ActiveSheet.UsedRange.Rows.Count).Copy
okno_tmp = ActiveWorkbook.Name
Workbooks(okno).Activate
List2.Activate
List2.Cells(List2.UsedRange.Rows.Count + 1, 2).Activate
rd = List2.UsedRange.Rows.Count + 1
ActiveCell.PasteSpecial xlPasteValues
List2.Range("A" & rd, "A" & List2.UsedRange.Rows.Count) = okno_tmp
Workbooks(okno_tmp).Close xlNo
End If
End If
Next
rd = 2
Do While List2.Cells(rd, 1) <> ""
If List2.Cells(rd, 2) = "Transakce" Then
List2.Rows(rd).Delete
Else
List2.Cells(rd, 2) = UCase(List2.Cells(rd, 2))
List2.Cells(rd, 3).Formula = "=left(A" & rd & ",8)&" & Chr(34) & "_" & Chr(34) & "&UPPER(B" & rd & ")"
rd = rd + 1
End If
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
M@citovat
RSS nejnovější články