VBA Hücre Birleştirme

[maliex]

iyi günler,

ekte mevcut olam tablom vba otomatik oluşturuyorum
ancak kendi içinde koşula bağlı birleştirmek istediğim alanlar var

örneği kırmızı ile belirttim yardımcı olursanız çok memnun olurum aradım tardım bir türlü çözemedim

 

[çıtır]

Deneyiniz.

Sub Hücrebirleştir()
Dim s1 As Worksheet: Dim i As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set s1 = Sheets("Sayfa1")
For i = s1.Cells(65535, "A").End(3).Row To 2 Step -1
If s1.Range("D" & i) = s1.Range("D" & i - 1) Then
s1.Range(s1.Cells(i, 4), s1.Cells(i - 1, 4)).MergeCells = True
s1.Cells(i, 4).HorizontalAlignment = xlCenter
s1.Cells(i, 4).VerticalAlignment = xlCenter
If s1.Range("F" & i - 1) = "" Then
s1.Range(s1.Cells(i, 6), s1.Cells(i - 1, 6)).MergeCells = True
s1.Cells(i, 6).HorizontalAlignment = xlCenter
s1.Cells(i, 6).VerticalAlignment = xlCenter
End If
End If
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[maliex]

Harikasınız tam istediğim gibi olmuş
peki her taksit sonrası ekteki gibi çizgi kalınlaştırmayı nasıl yapabiliriz(umarım çok olmuyorumdur cevap vermesenizde canınız sağolsun çok teşekkür ederim)

 

[çıtır]

Deneyiniz.

Sub Hücrebirleştir()
Dim s1 As Worksheet: Dim i As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set s1 = Sheets("Sayfa1")
For i = s1.Cells(65535, "A").End(3).Row To 2 Step -1
If s1.Range("D" & i + 1) <> s1.Range("D" & i) And s1.Range("D" & i).MergeCells = False Then
s1.Range("A" & i & ":" & "F" & i).Borders(xlEdgeBottom).Weight = xlMedium
End If
If s1.Range("D" & i) = s1.Range("D" & i - 1) Then
s1.Range(s1.Cells(i, 4), s1.Cells(i - 1, 4)).MergeCells = True
s1.Cells(i, 4).HorizontalAlignment = xlCenter
s1.Cells(i, 4).VerticalAlignment = xlCenter
End If
If s1.Range("F" & i - 1) = "" Then
s1.Range(s1.Cells(i, 6), s1.Cells(i - 1, 6)).MergeCells = True
s1.Cells(i, 6).HorizontalAlignment = xlCenter
s1.Cells(i, 6).VerticalAlignment = xlCenter
End If
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub