Pokusil jsem se o to, ale nejde mi to - myslíte, že byste mohl kouknout na celé to makro, které mám a případně mi to tam doplnit?
ještě jednou díky moc za pomoc..
Pavel
Sub RunBut_Click()
Dim SourceBook As Workbook
Dim TargetSheet As Worksheet
Dim SRow, TRow, TargetNameRow, SheetIndex As Integer
Dim FromDate, ActDate As Date
Dim Company As String
Dim Correct As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set TargetSheet = Sheets("Souhrn")
FromDate = Cells(2, 3)
TargetSheet.Activate
TRow = 2
While Not IsEmpty(TargetSheet.Cells(TRow, 1))
TargetSheet.Rows(TRow).Clear
TRow = TRow + 1
Wend
TargetNameRow = 2
TRow = 2
While Not IsEmpty(Cells(TargetNameRow, 1))
Company = Cells(TargetNameRow, 2)
Correct = Cells(TargetNameRow, 4)
Workbooks.Open Cells(TargetNameRow, 1), UpdateLinks:=False, ReadOnly:=True
Set SourceBook = Application.ActiveWorkbook
For SheetIndex = 1 To SourceBook.Sheets.Count
SRow = 4
While Not IsEmpty(SourceBook.Sheets(SheetIndex).Cells(SRow, 1))
If ActDate >= FromDate And SourceBook.Sheets(SheetIndex).Cells(SRow, 11) <> 0 Then
SourceBook.Sheets(SheetIndex).Activate
ActiveSheet.Rows(SRow).Copy
TargetSheet.Activate
ActiveSheet.Rows(TRow).PasteSpecial Paste:=xlPasteValues
ActiveSheet.Rows(TRow).PasteSpecial Paste:=xlPasteFormats
ActiveSheet.Cells(TRow, 16).Value = Company
ActiveSheet.Cells(TRow, 17).Value = Correct
TRow = TRow + 1
End If
SRow = SRow + 1
Wend
Next SheetIndex
Application.DisplayAlerts = False
SourceBook.Close
Application.DisplayAlerts = True
TargetNameRow = TargetNameRow + 1
Wend
TargetSheet.Cells(2, 1).Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("Hotovo!!")
End Sub
citovat