Dim Massiv1 (1 to 100000, 1 to 9)

Sub МассивТЕСТВБК()


Dim Massiv1() As Variant
Dim dimension1 As Long

Dim FilesToOpen
Dim x As Integer
Dim lastrowIMP As Long
Dim mainwbname As String, importwbname As String

Dim rCell As Range
Dim sMergeStr As String
Dim myCell As Range, myCell2 As Range, myPhrase As String, myPhrase1 As String
Dim lastrow As Long
Dim i As Long

mainwbname = ActiveWorkbook.Name

myPhrase = "Подраздел III.II Сведения о подтверждающих документах (справочно)"
myPhrase1 = "Подраздел III.I Сведения о подтверждающих документах"

FilesToOpen = Application.GetOpenFilename _
    (FileFilter:="Excel files(*.xls*),*.xls*", _
    MultiSelect:=True, Title:="Выберите EXCEL файлы")
    
If TypeName(FilesToOpen) = "Boolean" Then
    MsgBox "Не выбрано ни одного файла!"
    Exit Sub
End If

Application.ScreenUpdating = False
Application.DisplayAlerts = False

ReDim Massiv1(100000, 8)

x = 1

While x <= UBound(FilesToOpen)

    Set importwb = Workbooks.Open(Filename:=FilesToOpen(x))
    
    importwbname = importwb.Name
    With Worksheets(1).Range("AF9:BA9")
        For Each rCell In .Cells
            sMergeStr = sMergeStr & rCell.Text
        Next rCell
    End With
    
    Set myCell = ActiveSheet.UsedRange _
        .Find(myPhrase, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns)
    lastrowIMP = Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row

    Worksheets(1).Range("A" & (myCell.Row - 2) & ":BP" & lastrowIMP) _
        .EntireRow.Delete
    
    Set myCell2 = ActiveSheet.UsedRange _
        .Find(myPhrase1, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns)
    
    Worksheets(1).Range("A1:BP" & (myCell2.Row + 4)) _
        .EntireRow.Delete

    Workbooks(importwbname).Worksheets(1).Range("B1:C1, E1:M1, O1:R1, T1:V1, X1:Y1, AA1:AG1, AI1:AJ1, AL1:AR1, AS1:BP1") _
        .EntireColumn.Delete
    
    If WorksheetFunction.CountA(Worksheets(1).UsedRange) <> 0 Then
        lastrowIMP = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
        Worksheets(1).Range("I1:I" & lastrowIMP) = sMergeStr

        Massiv1 = Worksheets(1).UsedRange.Value

        sMergeStr = ""
        importwb.Close SaveChanges:=False
        x = x + 1
    Else
        Application.CutCopyMode = False
        sMergeStr = ""
        importwb.Close SaveChanges:=False
        x = x + 1
    End If

Wend

Application.DisplayAlerts = True

dimension1 = UBound(Massiv1, 1) + 1
Workbooks(mainwbname).Worksheets(1).Range("A2:I" & dimension1) = Massiv1

Application.ScreenUpdating = True


End Sub

Sub ВБК()

Dim FilesToOpen
Dim x As Integer
Dim lastrowIMP As Long

Dim rCell As Range
Dim sMergeStr As String
Dim myCell As Range, myCell2 As Range, myPhrase As Variant, myPhrase1 As Variant
Dim lastrow As Long
Dim i As Long, colNum As Long

mainwb = ActiveWorkbook.Name

myPhrase = "Подраздел III.II Сведения о подтверждающих документах (справочно)"
myPhrase1 = "Подраздел III.I Сведения о подтверждающих документах"

FilesToOpen = Application.GetOpenFilename _
    (FileFilter:="Excel files(*.xls*),*.xls*", _
    MultiSelect:=True, Title:="Выберите EXCEL файлы")
    
If TypeName(FilesToOpen) = "Boolean" Then
    MsgBox "Не выбрано ни одного файла!"
    Exit Sub
End If

Application.ScreenUpdating = False
Application.DisplayAlerts = False

x = 1
While x <= UBound(FilesToOpen)
    Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))
    
    With Worksheets(1).Range("AF9:BA9")
        For Each rCell In .Cells
            sMergeStr = sMergeStr & rCell.Text  'собираем текст из ячеек
        Next rCell
    End With
    
    Set myCell = ActiveSheet.UsedRange.Find(myPhrase)
    lastrowIMP = Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row

    With Range("A" & (myCell.Row - 2) & ":BP" & lastrowIMP)
        .EntireRow.Delete
    End With
    
    Set myCell2 = ActiveSheet.UsedRange.Find(myPhrase1)
    
    With Range("A1:BP" & (myCell2.Row + 4))
        .EntireRow.Delete
    End With
    
    Worksheets(1).Range("B1:C1, E1:M1, O1:R1, T1:V1, X1:Y1, AA1:AG1, AI1:AJ1, AL1:AR1, AS1:BP1") _
        .EntireColumn.Delete
    
    If WorksheetFunction.CountA(Worksheets(1).UsedRange) <> 0 Then
        lastrowIMP = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
        Worksheets(1).Range("I1:I" & lastrowIMP) = sMergeStr
        Worksheets(1).UsedRange.Copy
        Workbooks(mainwb).Worksheets(1).Range("A2").Insert shift:=xlDown
        sMergeStr = ""
        importWB.Close SaveChanges:=False
        x = x + 1
    Else
        sMergeStr = ""
        importWB.Close SaveChanges:=False
        x = x + 1
    End If
    
Wend

Application.DisplayAlerts = True

Workbooks(mainwb).Worksheets(1).Columns(1).Delete

Workbooks(mainwb).Worksheets(1).Range("A1") = "№ документа"
Workbooks(mainwb).Worksheets(1).Range("B1") = "Дата документа"
Workbooks(mainwb).Worksheets(1).Range("C1") = "Код вида документа"
Workbooks(mainwb).Worksheets(1).Range("D1") = "Код валюты документа"
Workbooks(mainwb).Worksheets(1).Range("E1") = "Сумма документа"
Workbooks(mainwb).Worksheets(1).Range("F1") = "Код валюты контракта"
Workbooks(mainwb).Worksheets(1).Range("G1") = "Сумма контракта"
Workbooks(mainwb).Worksheets(1).Range("H1") = "Уникальный № контракта"

lastrow = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row

With Workbooks(mainwb).Worksheets(1).Range("A1:H" & lastrow)
    .WrapText = False
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlCenter
    .Font.Name = "Times New Roman"
    .Font.Size = 10
    .Rows.AutoFit
    .Columns.AutoFit
    .Borders(xlEdgeLeft).LineStyle = xlContinuous
    .Borders(xlEdgeLeft).LineStyle = xlContinuous
    .Borders(xlEdgeBottom).LineStyle = xlContinuous
    .Borders(xlEdgeRight).LineStyle = xlContinuous
    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    .Borders(xlInsideVertical).LineStyle = xlContinuous
End With

Application.ScreenUpdating = True

End Sub

Function SummaRazd(Num, Optional Delim = "") As String

SummaRazd = IIf(Num < 0, "-", "") & Replace$(Trim$(Format$(Abs(Num), Right("### ### ### ### ### ### ### ### ### ###,##0.00", Len(Abs(Num)) + (Len(Abs(Num)) - 1) \ 3))), " ", Delim)

End Function

Sub аТестВставкаЯчеек()
Dim lastrow As Long, lastrow1 As Long, i As Long, numdiff as long


lastrow = Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row
lastrow1 = Worksheets(1).Cells(Rows.Count, .End(xlUp).Row

If lastrow < lastrow1 Then
    numdiff = lastrow1 - lastrow
    For i = 1 To numdiff
        Worksheets(1).Range("A" & lastrow - 1 & ":F" & lastrow - 1).Insert shift:=xlShiftDown
        lastrow1 = lastrow + 1
    Next i
ElseIf lastrow > lastrow1 Then
    numdiff = lastrow - lastrow1
    For i = 1 To numdiff
        Worksheets(1).Range("G" & lastrow1 - 1 & ":L" & lastrow1 - 1).Insert shift:=xlShiftDown
        lastrow1 = lastrow1 + 1
    Next i
Else

End If

End Sub