Soru Boşluk Sil, Aynı Hücreyi Birleştir ve Ortala

[RBozkurt]

Merhabalar
Aşağıda belirtmiş olduğum hususlarda yardımlarınıza ihtiyacım var. Şimdiden çok teşekkür ederim.

Örnek olarak eklemiş olduğum dosyada H sütunundaki boş hücre bulunan satırları silip ardından B sütunundaki aynı verili olan hücreleri birleştirip (bu hücreler zaten alt atla) ortalayarak bu biçimlendirmeyi A, C, D, E, F, G, K, L, M, N, O sütunlarına da kopyalamasını nasıl yapabilirim?
Referans olarak B sütunun alınması gereklidir.

Turuncu sütun birleşip sarılar bu biçimi referans alacak.

Kaynak ve Sonuç olarak 2 sayfa ekledim. İşlem kaynak sayfasında yaptırılacaktır. Sonuç sayfasını şablon olsun diye el ile yaptım, normade 2. bir sayfa yoktur.

Teşekkür ederim.

 

[RBozkurt]

Merhaba. Kusura bakmayın konu ile ilgili yardımcı olabilecek varmıdır?

 

[RBozkurt]

İyi günler. Aşağıdaki kod ile problem çözülmüştür. İhtiyacı olan revize edebilir.
Konu çözüldü şeklinde düzeltilebilir.

Option Explicit
Sub Satir_Sil_Bicim_Aktar()
Dim ws As Worksheet, lr As Integer, i As Integer, j As Integer
Dim BSatir As Integer, SSatir As Integer, deger As Variant
Set ws = ActiveSheet
lr = ws.Cells(Rows.Count, 2).End(xlUp).Row

For i = lr To 1 Step -1
          If WorksheetFunction.CountA(Sheets(1).Rows(i)) = 0 Then
                    ws.Rows(i).Delete
          End If
Next i
lr = ws.Cells(Rows.Count, 2).End(xlUp).Row
ws.Range("B2:B" & lr).UnMerge
deger = ""
Application.DisplayAlerts = False
With ws
          If deger = "" And ws.Range("B" & 2) <> "" Then deger = ws.Range("B" & 2): BSatir = 2
          For j = 2 + 1 To lr
                    If deger <> .Range("B" & j) And .Range("B" & j) <> "" Then
                              SSatir = j - 1
                              If BSatir <> SSatir Then
                                        .Range("A" & BSatir & ":" & "A" & SSatir).Merge
                                        .Range("B" & BSatir & ":" & "B" & SSatir).Merge
                                        .Range("C" & BSatir & ":" & "C" & SSatir).Merge
                                        .Range("D" & BSatir & ":" & "D" & SSatir).Merge
                                        .Range("E" & BSatir & ":" & "E" & SSatir).Merge
                                        .Range("F" & BSatir & ":" & "F" & SSatir).Merge
                                        .Range("G" & BSatir & ":" & "G" & SSatir).Merge
                                        .Range("K" & BSatir & ":" & "K" & SSatir).Merge
                                        .Range("L" & BSatir & ":" & "L" & SSatir).Merge
                                        .Range("M" & BSatir & ":" & "M" & SSatir).Merge
                                        .Range("N" & BSatir & ":" & "N" & SSatir).Merge
                                        .Range("O" & BSatir & ":" & "O" & SSatir).Merge
                              End If
                              deger = .Range("B" & j)
                              BSatir = j
                    End If
          Next j
End With
Application.DisplayAlerts = True
End Sub

 

[RBozkurt]

3. mesajdaki kodda hata tespit edilmiş olup güncel kod aşağıdakidir.

Spoyler: Kodlar

Option Explicit
Sub baslat()
Dim ws As Worksheet, lr As Integer, i As Integer, j As Integer
Dim BSatir As Integer, SSatir As Integer, deger As Variant
Dim bitti As Integer
Set ws = ActiveSheet
lr = ws.Cells(Rows.Count, 2).End(xlUp).Row
bitti = 0
For i = lr To 1 Step -1
          If WorksheetFunction.CountA(Sheets(ActiveSheet.Index).Rows(i)) = 0 Then
                    ws.Rows(i).Delete
          End If
Next i
With ws
lr = .Cells.Find(what:="*", After:=.Range("a1"), LookAt:=xlPart, _
                    LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row
                    
.Range("B2:B" & lr).UnMerge
deger = ""
Application.DisplayAlerts = False

          If deger = "" And ws.Range("B" & 2) <> "" Then deger = ws.Range("B" & 2): BSatir = 2
          For j = 2 + 1 To lr
                    If deger <> .Range("B" & j) And .Range("B" & j) <> "" Or bitti = 1 Then
                              SSatir = j - 1
                              If bitti = 1 Then SSatir = j
                              If BSatir <> SSatir Then
                                        .Range("A" & BSatir & ":" & "A" & SSatir).Merge
                                        .Range("B" & BSatir & ":" & "B" & SSatir).Merge
                                        .Range("C" & BSatir & ":" & "C" & SSatir).Merge
                                        .Range("D" & BSatir & ":" & "D" & SSatir).Merge
                                        .Range("E" & BSatir & ":" & "E" & SSatir).Merge
                                        .Range("F" & BSatir & ":" & "F" & SSatir).Merge
                                        .Range("G" & BSatir & ":" & "G" & SSatir).Merge
                                        .Range("K" & BSatir & ":" & "K" & SSatir).Merge
                                        .Range("L" & BSatir & ":" & "L" & SSatir).Merge
                                        .Range("M" & BSatir & ":" & "M" & SSatir).Merge
                                        .Range("N" & BSatir & ":" & "N" & SSatir).Merge
                                        .Range("O" & BSatir & ":" & "O" & SSatir).Merge
                              End If
                              deger = .Range("B" & j)
                              BSatir = j
                    End If
                    If j + 1 = lr Then
                              bitti = 1
                    End If
          Next j
End With
Application.DisplayAlerts = True
End Sub