Объединить ячейки с повторяющимися значениями

Private Function Oplaty()
Dim XL As Object, XLBook As Object, XLSheet As Object
    Dim ClientDir As String, TmplFile As String, OutputDir As String, OutputFile As String, Pos As Long, df As String
    Dim rst As Object, SubRst As Object, StrN As Long
    Dim opl As String
    Dim LogN As Integer, VzakN As Integer, Nach As Integer
 
'    Set rst = CurrentDb.OpenRecordset("SELECT * FROM ÎïëàòûÄàòû ORDER BY Íîìåð", dbOpenDynaset, dbSeeChanges)
 
Set rst = CurrentDb.OpenRecordset("SELECT Çàêàç.Íîìåð, Çàêàç.Ïîñòàâùèê, Çàêàç.ÍîìåðÂýä, Îïëàòà.Ñóììà, Îïëàòà.Ïîäïèñàí, " _
& " Îïëàòà.Ïîëó÷åíû, [Èòîãîâàÿ ñóììà çàêàçà].ñóìì, [Ñóììà]/[ñóìì] AS Ïðîöåíòû" _
& " FROM (Çàêàç INNER JOIN Îïëàòà ON Çàêàç.Íîìåð = Îïëàòà.Çàêàç)" _
& " INNER JOIN [Èòîãîâàÿ ñóììà çàêàçà] ON Çàêàç.Íîìåð = [Èòîãîâàÿ ñóììà çàêàçà].Íîìåð", dbOpenDynaset, dbSeeChanges)
 
    TmplFile = "\\server.az\Data\Îòäåë çàêóïîê\! ABS\Øàáëîíû\Îïëàòû.xlsx"
 
    sPatchtDir = Environ("ALLUSERSPROFILE") & "\Îïëàòû"
        If Dir$(sPatchtDir, vbDirectory) = "" Then
        MkDir sPatchtDir
    End If
 
    OutputFile = sPatchtDir & "\Îïëàòû.xlsx"
    FileCopy TmplFile, OutputFile
           ''Ñîçäàòü îáúåêòû Excel
           
'On Error GoTo OLEError
    Set XL = CreateObject("Excel.Application")
 
'On Error GoTo AnyError
    Set XLBook = XL.Workbooks.Open(OutputFile)
 
           ''Âûâîä â êîíêðåòíûé øàáëîí
 
           ''1-é ëèñò Çàïîëíÿåì øàïêó
        Set XLSheet = XLBook.Worksheets(1)
        XLSheet.Activate
        XLSheet.Cells(1, 1).value = "Íàçâàíèå êîìïàíèè"
        XLSheet.Cells(1, 2).value = "Êîíòàêòíîå ëèöî"
        XLSheet.Cells(1, 3).value = "¹ çàêàçà"
        XLSheet.Cells(1, 4).value = "Èíâîéñ ïî ïðîåêòó"
        XLSheet.Cells(1, 5).value = "Ñóììà èíâîéñà"
        XLSheet.Cells(1, 6).value = "Ñóììà ê îïëàòå"
        XLSheet.Cells(1, 7).value = "ïðîöåíòíàÿ ÷àñòü"
        XLSheet.Cells(1, 8).value = "Äàòà ïîäà÷è ñ÷åòà ìåíåäðåðîì ÎÌÇ"
        XLSheet.Cells(1, 9).value = "Äàòà ïîäòâåðæäåíèÿ èíâîéñà Ñòðîéêîâûì Ì.Ì."
        XLSheet.Cells(1, 10).value = "Äàòà ïåðåäà÷è ïîäòâåðæäåííîãî èíâîéñà â îòäåë ÂÝÄ"
        XLSheet.Cells(1, 11).value = "Äàòà îïëàòû"
        XLSheet.Cells(1, 12).value = "Äàòà ïîëó÷åíèå îïëàòû"
 
           ''Âûãðóçêà заказов
 
        StrN = 2
        Do While Not rst.EOF
'        XLSheet.Cells(StrN, 1) = rst![]
        XLSheet.Cells(StrN, 2) = rst![Ïîñòàâùèê]
        XLSheet.Cells(StrN, 3) = rst![ÍîìåðÂÝÄ]
'        XLSheet.Cells(StrN, 4) = rst![]
        XLSheet.Cells(StrN, 5) = rst![ñóìì]
        XLSheet.Cells(StrN, 6) = rst![Ñóììà]
        XLSheet.Cells(StrN, 7) = rst![Ïðîöåíòû]
'        XLSheet.Cells(StrN, 8) = rst![]
'        XLSheet.Cells(StrN, 9) = rst![]
'        XLSheet.Cells(StrN, 10) = rst![]
        XLSheet.Cells(StrN, 11) = rst![Ïîäïèñàí]
        XLSheet.Cells(StrN, 12) = rst![Ïîëó÷åíû]
        Postavshik = rst![Ïîñòàâùèê]
            rst.MoveNext
            StrN = StrN + 1
        Loop
    
    XLBook.Save
    XLBook.Application.ActiveWorkbook.RefreshAll
    XL.Visible = True
    Oplaty = True
    Exit Function
 
'OLEError:
'    MsgBox "Microsoft Excel - íå óñòàíîâëåí.", , "Îøèáêà âûâîäà ôîðìû " & TmplName
'    Oplaty = False
'    Exit Function
'
'AnyError:
'    MsgBox "Íåîïîçíàííàÿ îøèáêà.", , "Îøèáêà âûâîäà ôîðìû " & TmplName
'    Oplaty = False
'    Exit Function
End Function

Sub Макрос3()
'
' Макрос3 Макрос
'
 
'
    Range("B22:B26").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
End Sub

   Dim MyRange As Excel.Range
 
      Set MyRange = XLSheet.Range(XLSheet.Cells(2, 2), XLSheet.Cells(22, 2))
      MyRange.Merge

   ''код...           
    nomNach = Nz(nomPos)
        XLSheet.Cells(StrN, 3) = rst![НомерВЭД]
                  nomPos = Nz(rst![НомерВЭД])
                  '' NachalYache - это переменная от которой начнется объединение
                  ''StrN - это на какой ячейки объединение закончиться 
 
            If nomPos = "" Then  ''тут думал сохранять номер последней ячейки в которой ничего не было 
                 NachalYache = StrN - 1
            End If
            
           'тут думал сохранять номер последней ячейки в которой есть данные
           ''вот тут то скорее всего и есть проблема, по условию nomPos действительно не равна пустоте и nomPos <> nomNach
            '' и по этому получается NachalYache будет перезаписываться.. т.е я уже не получу начальную цифру с которой должно быть объединение, а полу предпоследнюю цифру
            '' и получиться будут пропущены все повторяющиеся ячейки, а объединены будут только две последние
            If nomPos <> "" And nomPos <> nomNach Then  
                 NachalYache = StrN - 1 
            End If
 
              If nomNach <> nomPos And nomPos <> "" Then
'                  NomerVedNach = StrN - NachalYache
                  Set MyNomVed = XLSheet.Range(XLSheet.Cells(NachalYache, 3), XLSheet.Cells(StrN, 3))
 
                  MyNomVed.Application.DisplayAlerts = False ''Убираем сообщение: Объединение ячеек приведет к потере всех значений, кроме левого верхнего
                  MyNomVed.Merge
                  MyNomVed.WrapText = True   ''Переносить по словам
            End If
''код...