Sub mrshkei()


Dim sh As Worksheet, sh2 As Worksheet, arr, arr2, arr3
Dim i As Long, n As Long, k As Long, lr As Long, lr2 As Long
   
    Set sh = Worksheets("Íîâàÿ_ïàðòèÿ"):
    Set sh2 = Worksheets("Ñòàðàÿ_ïàðòèÿ")
   
    lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
    lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row
   
    arr = sh.Range("A1:J" & lr)
    arr2 = sh2.Range("A1:I" & lr2)
        ReDim arr3(1 To UBound(arr), 1 To 2)
 
        For i = LBound(arr) + 1 To UBound(arr)
        k = 0
        For n = LBound(arr2) + 1 To UBound(arr2)
        If arr(i, 1) = arr2(n, 1) Then
        k = k + 1
        If arr(i, 7) - arr2(n, 7) <> 0 Then
            arr3(i - 1, 1) = "èçìåíåíèå îáúåìà"
            arr3(i - 1, 2) = arr2(i - 1, 7)
            Exit For
        Else
            arr3(i - 1, 1) = Empty
            arr3(i - 1, 2) = Empty
        End If
        End If
        If k = 0 Then
            arr3(i - 1, 1) = "äà"
            arr3(i - 1, 2) = "íîâàÿ ïîçèöèÿ"
        End If
    Next n
Next i
 
sh.Range("I2").Resize(UBound(arr3), 2) = arr3


End Sub

Sub Макрос3()
    Dim arrData(), arrResult(), fRegion
    Dim CriteriaColumn As Integer
    Dim CurrentRow As Long, i As Long, j As Long
    
    fRegion = "Калининград"
    CriteriaColumn = 5
    
    arrData = Sheets("Data").Cells(2, 1).CurrentRegion.Value
    ReDim arrResult(1 To UBound(arrData, 1), 1 To UBound(arrData, 2))
    
    i = 1
    CurrentRow = 1
    For j = 1 To UBound(arrData, 2)
        arrResult(CurrentRow, j) = arrData(i, j)
    Next j
    CurrentRow = CurrentRow + 1
    
    For i = 2 To UBound(arrData, 1)
        If arrData(i, CriteriaColumn) = fRegion Then
            For j = 1 To UBound(arrData, 2)
                arrResult(CurrentRow, j) = arrData(i, j)
            Next j
            CurrentRow = CurrentRow + 1
        End If
    Next i
    
    With Sheets("result")
        .Cells.Clear
        .Range(.Cells(1, 1), .Cells(CurrentRow, UBound(arrData, 2))).Value = arrResult
    End With
  
End Sub

Sub CopyData()
              
                
        Dim wbkX As Workbook                        'книга
        Dim shtSv As Worksheet, shtX As Worksheet   'листы
        Dim rngSv As Range, rngX As Range           'диапазоны
  
        Dim NrowSv As Long, NrowX As Long           'число строк
        Dim NcolSv As Integer, NcolX As Integer     'число столбцов

        Dim TitleSv, TitleX         '"будущие" массивы заголовков
        Dim i As Long, j As Long    'счетчики циклов

        Dim rngCopy As Range, rngPaste As Range     'что копировать и куда вставить


            Set wbkX = ThisWorkbook
  
  '= 1 == для листа "лист1" ======================
  Set shtSv = wbkX.Worksheets("Лист1")
  Set rngSv = shtSv.Range("A1").CurrentRegion
  NrowSv = rngSv.Rows.Count
  NcolSv = rngSv.Columns.Count
  TitleSv = rngSv.Rows(1)
  
  '= 2 == Цикл по всем листам, кроме "Лист1" ======================
  For Each shtX In wbkX.Worksheets
    Select Case shtX.Name
      Case "Лист1"   'для листа "реестр" - ничего не делаем!
      Case Else       '-- 3 -- для прочих листов ---------
        Set rngX = shtX.Range("A1").CurrentRegion
        NrowX = rngX.Rows.Count
        NcolX = rngX.Columns.Count
        TitleX = rngX.Rows(1)
        '-- 4 -- поиск совпадающих заголовков ---------
        For i = 1 To NcolSv
          For j = 1 To NcolX
            '-- 5 -- если заголовки совпали, то ...
            If TitleSv(1, i) = TitleX(1, j) Then
  '- 6 - что копировать ----
  Set rngCopy = Range(rngX.Cells(2, j), rngX.Cells(NrowX, j))
  '- 7 - куда вставить  ----
  Set rngPaste = rngSv.Cells(1 + 1, i).Resize(NrowX - 1, 1)
  '- 8 - копирование через буфер обмена -----
     rngCopy.Copy
     rngPaste.PasteSpecial
             End If
          Next j
        Next i
        '-- 9 -- определить новые размеры диапазона на листе "Лист1"  ---
        Set rngSv = shtSv.Range("A1").CurrentRegion
        NrowSv = rngSv.Rows.Count
    End Select
  Next shtX   '== конец цикла по листам ========================================
                
End Sub

Sub CopyData()
        Dim wrkSv As Workbook
        
        'Открываем книгу источник откуда будем копировать данные
        Set wrkSv = Workbooks.Open("C:\Users\sega4\OneDrive\Рабочий стол\Первый проект\Исходные данные.xlsx")
                   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Workbooks("Исходные данные.xlsx").Activate
    Sheets("Лист1").Select
    Sheets("Лист1").Copy After:=Workbooks("Сохраненые файлы.xlsm").Sheets(1)
           
    'Закрываем книгу откуда мы скопировали данные
    Workbooks("Исходные данные.xlsx").Close
        
                
        Dim wbkX As Workbook                        'книга
        Dim shtSv As Worksheet, shtX As Worksheet   'листы
        Dim rngSv As Range, rngX As Range           'диапазоны
  
        Dim NrowSv As Long, NrowX As Long           'число строк
        Dim NcolSv As Integer, NcolX As Integer     'число столбцов

        Dim TitleSv, TitleX         '"будущие" массивы заголовков
        Dim i As Long, j As Long    'счетчики циклов

        Dim rngCopy As Range, rngPaste As Range     'что копировать и куда вставить


            Set wbkX = ThisWorkbook
  
  '= 1 == для листа "реестр" ======================
  Set shtSv = wbkX.Worksheets("реестр")
  Set rngSv = shtSv.Range("A1").CurrentRegion
  NrowSv = rngSv.Rows.Count
  NcolSv = rngSv.Columns.Count
  TitleSv = rngSv.Rows(1)
  
  '= 2 == Цикл по всем листам, кроме "Лист1" ======================
  For Each shtX In wbkX.Worksheets
    Select Case shtX.Name
      Case "реестр"   'для листа "реестр" - ничего не делаем!
      Case Else       '-- 3 -- для прочих листов ---------
        Set rngX = shtX.Range("A1").CurrentRegion
        NrowX = rngX.Rows.Count
        NcolX = rngX.Columns.Count
        TitleX = rngX.Rows(1)
        '-- 4 -- поиск совпадающих заголовков ---------
        For i = 1 To NcolSv
          For j = 1 To NcolX
            '-- 5 -- если заголовки совпали, то ...
            If TitleSv(1, i) = TitleX(1, j) Then
  '- 6 - что копировать ----
  Set rngCopy = Range(rngX.Cells(2, j), rngX.Cells(NrowX, j))
  '- 7 - куда вставить  ----
  Set rngPaste = rngSv.Cells(1 + 1, i).Resize(NrowX - 1, 1)
  '- 8 - копирование через буфер обмена -----
     rngCopy.Copy
     rngPaste.PasteSpecial
             End If
          Next j
        Next i
        '-- 9 -- определить новые размеры диапазона на листе "Лист1"  ---
        Set rngSv = shtSv.Range("A1").CurrentRegion
        NrowSv = rngSv.Rows.Count
    End Select
  Next shtX   '== конец цикла по листам ========================================
              
    'Удаление листа
    Worksheets("Лист1").Delete
         
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   
End Sub