Option Explicit 'оптимизирует и защищает, но усложняет жизнь


'ALERT!!! код нужно дописать в местах, где указан ALERT + желательно там, где указан Warning (но необязательно)


Function Razmer(ByVal filename As String, What As String, ByVal size As Integer) As Integer 'size мы можем захотеть переопределить
'Функция для определения номера столбца What документа filename (ищет по строкам от 1 до size)
Dim i As Long
For i = 1 To size
    If InStr(Workbooks(IIf(Len(filename) <> 0, filename, 1)).Worksheets(1).Cells(1, i), What) <> 0 Then
        Razmer = i
        Exit For
    End If
Next i
End Function

Function Fileopener() As String
'Функция для открытия диалога выбора файла. Возвращает имя выбранного файла
'Нужно дописать ELSEIF .Show = 0, но конкретную логику реализовать в зависимости от рабочих задач, но пока не совсем понимаю как это встраивается в логику и как работает данная часть
Dim fd As Office.FileDialog 'переменная для вызова диалога файла
Dim filename As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd

    .AllowMultiSelect = False
    .Title = "Please select file"
    .Filters.Clear
    .Filters.Add "Excel", "*.xls?"

    If .Show = True Then
        filename = Dir(.SelectedItems(1))
    End If
End With

Application.DisplayAlerts = False
Fileopener = filename
End Function

Sub Main()
'блок объявления переменных
Dim ind As Integer 'количество столбцов исходного документа
Dim nrow As Long 'количество строк исходного документа
Dim pind As Integer 'номер столбца PIN исходного документа
Dim npind As Integer 'номер столбца PIN документа для дописывания
Dim nind As Integer 'количество столбцов документа для дописывания
Dim mnrow As Long 'количество строк документа для дописывания
Dim mnemind As Integer 'количество столбцов документа мнемоники
Dim mnemrow As Long 'количество строк документа мнемоники
Dim carcbr As Integer 'номер столбца carcbr документа мнемоники
Dim icarcbr As Integer 'номер столбца carcbr документа для дописывания
Dim cabad As Integer 'номер столбца мнемоники для связи с документом для дописывания
Dim i As Long 'просто счётчик с помощью которого иттерируемся (для строк)
Dim j As Integer 'ещё один вспомогательный счётчик для иттерации (для столбцов)
Dim st As Integer 'количество столбцов (для переопределения)
Dim mosind, regionind As Integer 'количество столбцов файлов москвы и регионов
Dim mosrow, regionrow As Long 'количество строк файлов москвы и регионов
Dim filename, mnemonic, mos, region As String 'соответствующие названия файлов
Dim fcell As Range 'вспомогательная переменная для поиска совпадений файла мнемоники

'блок начальной инициализации
With Application
    .ScreenUpdating = False: .EnableEvents = False: .Calculation = False 'отключил самое очевидное, что не нужно для быстродействия
End With

'блок сбора информации с исходного файла
ThisWorkbook.Activate
ind = Worksheets(1).Rows(1).End(xlToRight).Column + 1
nrow = Worksheets(1).Columns(1).End(xlDown).row + 1
pind = Razmer("", "PIN", ind)
st = ind
ind = Razmer("", "Статус оповещения", ind)

'блок открытия файла для дозаписи для удобства Оли создал месседж бокс
MsgBox "Выберите файл для дописывания"
filename = Fileopener()
Workbooks.Open (filename)

If Err <> 0 Then
    MsgBox "Что-то пошло не так..."
    Exit Sub
End If

'блок сбора информации о файле для дозаписи
nind = Workbooks(filename).Worksheets(1).Rows(1).End(xlToRight).Column + 1
mnrow = Workbooks(filename).Worksheets(1).Columns(1).End(xlDown).row + 1
npind = Razmer(filename, "PIN", nind)
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'icarcbr = Razmer(filename, "Мнемоника оповещения", nind) 'ALERT:Здесь не уверен - нужно уточнить у Кирилла
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
nind = Razmer(filename, "Статус оповещения", nind)

'блок дозаписи
For i = 2 To nrow ' цикл по количеству строк исходного файла
    If InStr(Workbooks(1).Worksheets(1).Cells(i, ind), "Non-participating FFI") <> 0 Then 'Если в очередной строке первоначального файла содержится нужная строка
        If WorksheetFunction.CountIf( _
        Workbooks(filename).Worksheets(1).Columns(npind), _
        Workbooks(1).Worksheets(1).Cells(i, pind)) = 0 Then
        ' если в соответствующем столбце файла для дозаписи нет ни 1 PIN'a очередной строки исходного файла

        For j = 1 To st
            Set fcell = Workbooks(filename).Worksheets(1).Cells(1, 1).EntireRow.Find( _
            Workbooks(1).Worksheets(1).Cells(1, j))
            If Not fcell Is Nothing Then
                Workbooks(filename).Worksheets(1).Cells(mnrow, fcell.Column) = _
                Workbooks(1).Worksheets(1).Cells(i, j)
            End If
        Next j
            'Workbooks(1).Worksheets(1).Cells(i, 1).EntireRow.Copy Workbooks(filename).Worksheets(1).Cells(mnrow, 1).EntireRow
            'строка выше устарела

        ' вставляем из буфера всю строку в конец файла для дозаписи.
        'WARNING: может закрасться ошибка, когда первый столбец частично не заполнен.
        'перед запуском всей программы лучше заполнить ВСЕ пустые ячейки
        'методами excel это сделать можно сразу несколькими способами.
        'Так что, в качестве TO DO: доработать безопасность
        Workbooks(1).Worksheets(1).Cells(i, 1).EntireRow.Interior.Color = vbCyan 'красим в бирюзовый новые данные
        Workbooks(filename).Worksheets(1).Cells(mnrow, 1).EntireRow.Interior.Color = vbCyan 'красим в бирюзовый новые данные
        mnrow = mnrow + 1
        End If
    End If
Next i

'блок открытия файла мнемоники
'MsgBox "Выберите файл мнемоники"
'mnemonic = Fileopener()
'Workbooks.Open (mnemonic)
'If Err <> 0 Then
    'MsgBox "Что-то пошло не так..."
    'Exit Sub
'End If

'блок сбора информации о файле мнемоники
'mnemind = Workbooks(mnemonic).Worksheets(1).Rows(1).End(xlToRight).Column + 1
'mnemrow = Workbooks(mnemonic).Worksheets(1).Columns(1).End(xlDown).row + 1
'cabad = Razmer(mnemonic, "CABAD1", mnemind)
'carcbr = Razmer(mnemonic, "CARCBR", mnemind)

'блок открытия файла для москвы
MsgBox "Выберите файл москвы"
mos = Fileopener()
Workbooks.Open (mos)
If Err <> 0 Then
    MsgBox "Что-то пошло не так..."
    Exit Sub
End If

'блок сбора информации о файле для москвы
mosind = Workbooks(mos).Worksheets(1).Rows(1).End(xlToRight).Column + 1
mosrow = Workbooks(mos).Worksheets(1).Columns(1).End(xlDown).row + 1


'блок открытия файла для регионов
MsgBox "Выберите файл регионов"
region = Fileopener()
Workbooks.Open (region)
If Err <> 0 Then
    MsgBox "Что-то пошло не так..."
    Exit Sub
End If

'блок сбора информации о файле для регионов
regionind = Workbooks(region).Worksheets(1).Rows(1).End(xlToRight).Column + 1
regionrow = Workbooks(region).Worksheets(1).Columns(1).End(xlDown).row + 1

'блок сепарации файла дозаписи на файл москвы и регионов (не создаются, а тоже дозаписываются)
'WARNING: самый медленный блок. Можно подумать о методах для оптимизации.
'из неэфективных по памяти - кеширование, ассоциации для ячеек (пропускать те, которые уже были обработаны,
'алгоритмы неравномерного поиска, работа с более быстрыми контейнерами)
'из сомнительных выигрышей по времени - подбор более эффективного алгоритма поиска (сомнительный т.к для
'большинства наиболее эффективных потребуется делать ещё и сортировку, что может оказаться не лучшим решением)
'для большей уверености нужны оценки на живой выборке - а оно может и не надо никому...
For i = 2 To mnrow 'по всем строкам документа для дописывания

    'Set fcell = Workbooks(mnemonic).Worksheets(1).Cells(2, carcbr).EntireColumn.Find( _
    'Workbooks(filename).Worksheets(1).Cells(i, icarcbr))
    'с помощью стандартного метода find ищем совпадения.
    'WARNING: логика что делать если совпадений нет - не продумана. может привести к вылету
    'If InStr(Workbooks(mnemonic).Worksheets(1).Cells(fcell.row, cabad), "MOCO") <> 0 Then 'по москве

    If InStr(1, Workbooks(filename).Worksheets(1).Cells(i, 12), "F_M", vbTextCompare) Then
        For j = 1 To mosind
            Set fcell = Workbooks(mos).Worksheets(1).Cells(1, 1).EntireRow.Find( _
            Workbooks(filename).Worksheets(1).Cells(1, j))
            If Not fcell Is Nothing Then
                Workbooks(mos).Worksheets(1).Cells(mnrow, fcell.Column) = _
                Workbooks(filename).Worksheets(1).Cells(i, j)
            End If
        Next j
        'Workbooks(filename).Worksheets(1).Cells(i, 1).EntireRow.Copy Workbooks(mos).Worksheets(1).Cells(mosrow, 1).EntireRow
        'строка выше устарела
        Workbooks(mos).Worksheets(1).Cells(mosrow, 1).EntireRow.Interior.Color = vbCyan 'помечаем
        mosrow = mosrow + 1


    Else ' по регионам
        For j = 1 To regionind
            Set fcell = Workbooks(region).Worksheets(1).Cells(1, 1).EntireRow.Find( _
            Workbooks(filename).Worksheets(1).Cells(1, j))
            If Not fcell Is Nothing Then
                Workbooks(region).Worksheets(1).Cells(mnrow, fcell.Column) = _
                Workbooks(filename).Worksheets(1).Cells(i, j)
            End If
        Next j
        'Workbooks(filename).Worksheets(1).Cells(i, 1).EntireRow.Copy Workbooks(region).Worksheets(1).Cells(regionrow, 1).EntireRow
        'строка выше устарела
        Workbooks(region).Worksheets(1).Cells(regionrow, 1).EntireRow.Interior.Color = vbCyan
        regionrow = regionrow + 1
    End If
Next i

'финализирующий блок. Сохраняем, закрываем
Workbooks(mos).Save
Workbooks(mos).Close
Workbooks(region).Save
Workbooks(region).Close
Workbooks(filename).Save
Workbooks(filename).Close
With Application
    .ScreenUpdating = True: .EnableEvents = True: .Calculation = True
End With

MsgBox "Сделано"

End Sub