Макрос для работы с несколькими документами

Option Base 1
 
Sub qweqwe()
Dim Wb As Workbook
Dim Nwb As Workbook
Dim Da1 As Date, Da2 As Date
Dim FDS As FileDialogSelectedItems
Dim File$, k As Long, s As Long, sC%
Dim Arr1, Arr2, Arr3
Dim Arr
Dim MaxSc%
 
Application.ScreenUpdating = False
 
Da1 = ThisWorkbook.Sheets(1).Cells(1, 1)
Da2 = ThisWorkbook.Sheets(1).Cells(1, 2)
 
Set Wb1 = Workbooks.Open(GFC("Выберите файл1", ThisWorkbook.Path))
Set Wb2 = Workbooks.Open(GFC("Выберите файл2", ThisWorkbook.Path))
Set Wb3 = Workbooks.Open(GFC("Выберите файл3", ThisWorkbook.Path))
 
s = Wb1.Sheets(1).Cells(1, 1).End(xlDown).Row
sC = Wb1.Sheets(1).Cells(1, 1).End(xlToRight).Column
If sC > MaxSc Then MaxSc = sC
Arr1 = Range(Wb1.Sheets(1).Cells(1, 1), Wb1.Sheets(1).Cells(s, sC))
 
s = Wb2.Sheets(1).Cells(1, 1).End(xlDown).Row
sC = Wb2.Sheets(1).Cells(1, 1).End(xlToRight).Column
If sC > MaxSc Then MaxSc = sC
Arr2 = Range(Wb2.Sheets(1).Cells(1, 1), Wb2.Sheets(1).Cells(s, sC))
 
s = Wb3.Sheets(1).Cells(1, 1).End(xlDown).Row
sC = Wb3.Sheets(1).Cells(1, 1).End(xlToRight).Column
If sC > MaxSc Then MaxSc = sC
Arr3 = Range(Wb3.Sheets(1).Cells(1, 1), Wb3.Sheets(1).Cells(s, sC))
 
Wb1.Close False
Wb2.Close False
Wb3.Close False
 
ReDim Arr(UBound(Arr1) + UBound(Arr2) + UBound(Arr3), MaxSc)
 
k = 1
 
 
For i = 1 To UBound(Arr1)
    If CDate(Arr1(i, 1)) >= Da1 And CDate(Arr1(i, 1)) <= Da2 Then
        For j = 1 To UBound(Arr1, 2)
            Arr(k, j) = Arr1(i, j)
        Next j
        k = k + 1
    End If
Next i
 
For i = 1 To UBound(Arr2)
    If CDate(Arr2(i, 1)) >= Da1 And CDate(Arr2(i, 1)) <= Da2 Then
        For j = 1 To UBound(Arr2, 2)
            Arr(k, j) = Arr2(i, j)
        Next j
        k = k + 1
    End If
Next i
 
For i = 1 To UBound(Arr3)
    If CDate(Arr3(i, 1)) >= Da1 And CDate(Arr3(i, 1)) <= Da2 Then
        For j = 1 To UBound(Arr3, 2)
            Arr(k, j) = Arr3(i, j)
        Next j
        k = k + 1
    End If
Next i
 
Set Nwb = Workbooks.Add(xlWBATWorksheet)
Nwb.Sheets(1).Cells(1, 1).Resize(UBound(Arr), UBound(Arr, 2)) = Arr
 
End Sub
 
Function GFC(Optional ByVal Title As String = "Выберите файл для обработки", _
                     Optional ByVal InitialPath, _
                     Optional ByVal MyFilter As String = "Excel (*.xls*),") As String
    If Not IsMissing(InitialPath) Then
        On Error Resume Next: ChDrive Left(InitialPath, 1)
        ChDir InitialPath
    End If
    res = Application.GetOpenFilename(MyFilter, , Title, "Открыть")
    GetFileName = IIf(VarType(res) = vbBoolean, "", res)
End Function

Sub qqq()
Dim src As Worksheet, dst As Worksheet, params As Range
    Set src = ActiveSheet
    Set dst = ThisWorkbook.Worksheets("result")
    Set params = ThisWorkbook.Worksheets("params").Cells
    dfrom = params(1, 2)
    dto = params(2, 2)
    col = params(3, 2)
    dst_r = dst.Cells(dst.Cells.Rows.Count, 1).End(xlUp).Row
    If dst.Cells(dst_r, 1) <> "" Then dst_r = dst_r + 1
 
    Application.ScreenUpdating = False
    For r = 1 To src.UsedRange.Rows.Count
        If dfrom <= Cells(r, 1) And Cells(r, 1) <= dto Then
            Range(Cells(r, 2), Cells(r, 1 + col)).Copy dst.Cells(dst_r, 1)
            dst_r = dst_r + 1
        End If
    Next
    Application.CutCopyMode = False
    dst.Activate
    Application.ScreenUpdating = True
End Sub