Макрос для работы с несколькими документами - VBA - Ответ 9556832

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