Hücre birleştirme

[ASLAN7410]

Merhaba hayırlı geceler.

Ekte gönderdiğim excel dosyamın Sayfa1'de uzun bir verim var.

Yapmak istediğim butona bastığımda Sayfa1'deki verileri Sayfa2'ye yapıştırıp C sütunundaki aynı
bilgiler ile D sütunundaki aynı bilgilerin karşısındaki olan F-G-H sütunundaki verilerin hücrelerini
birleştirerek veriler birbirine karışmaması için aralarına bir boşluk atmasını istiyorum.

Yardımcı olur musunuz?

http://dosya.co/7h9ci29mpfg2/Örnek.xlsm.html

 

[Asri]

Linkteki dosyayı inceleyiniz.

İşlemin sağlıklı olması için sayfa1 de verilerin sıralanmış olması gerekiyor.
Çalışma anındaki veri sıralama iptal edildi.

İşlem tamamlandı mesajı alana kadar beklemeniz gerekiyor.

http://dosya.co/crzhof17cr17/hucre_birlestir.xlsm.html

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
   On Error Resume Next
   WorksheetExists = (Sheets(WorksheetName).Name <> "")
   On Error GoTo 0
End Function

Sub kopyala_birlestir()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    If WorksheetExists("Sonuc") Then Sheets("Sonuc").Delete
    
    Columns("A:H").Select
    Selection.Copy
    Set NewSh = Sheets.Add(After:=Sheets(Sheets.Count))
    NewSh.Name = "Sonuc"
    sayfaadi = NewSh.Name
    ActiveSheet.Paste
    
    Columns("A:H").Select
    Application.CutCopyMode = False
    
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    'kolona = "A1:H" & sonsatir
    'kolonc = "C2:C" & sonsatir
    'kolond = "D2:D" & sonsatir
    
    ' ActiveWorkbook.Worksheets(sayfaadi).Sort.SortFields.Clear
    ' ActiveWorkbook.Worksheets(sayfaadi).Sort.SortFields.Add Key:=Range(kolonc) _
   '     , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
   ' ActiveWorkbook.Worksheets(sayfaadi).Sort.SortFields.Add Key:=Range(kolond) _
   '     , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
   ' With ActiveWorkbook.Worksheets(sayfaadi).Sort
   '     .SetRange Range(kolona)
   '     .Header = xlYes
   '     .MatchCase = False
   '      .Orientation = xlTopToBottom
   '     .SortMethod = xlPinYin
   '     .Apply
   ' End With
    
    Call bir_satir_bos
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    
    basla = 0
    For i = 1 To sonsatir + 1
       sayi = Cells(i, 3).Value
       isim = Cells(i, 4).Value
       If i = 1 Then basla = 2
 
       If sayi <> eskisayi And isim <> eskiisim And i > 2 Then
         kolonf = "F" & basla & ":F" & i - 1
         kolong = "G" & basla & ":G" & i - 1
         kolonh = "H" & basla & ":H" & i - 1
         Range(kolonf).Select
         With Selection
          .HorizontalAlignment = xlCenter
          .VerticalAlignment = xlCenter
          .WrapText = False
          .Orientation = 0
          .AddIndent = False
          .IndentLevel = 0
          .ShrinkToFit = False
          .ReadingOrder = xlContext
          .MergeCells = False
         End With
         Selection.Merge
         Range(kolong).Select
         With Selection
           .HorizontalAlignment = xlCenter
           .VerticalAlignment = xlCenter
           .WrapText = False
           .Orientation = 0
           .AddIndent = False
           .IndentLevel = 0
           .ShrinkToFit = False
           .ReadingOrder = xlContext
           .MergeCells = False
         End With
         Selection.Merge
         Range(kolonh).Select
         With Selection
           .HorizontalAlignment = xlCenter
           .VerticalAlignment = xlCenter
           .WrapText = False
           .Orientation = 0
           .AddIndent = False
           .IndentLevel = 0
           .ShrinkToFit = False
           .ReadingOrder = xlContext
           .MergeCells = False
         End With
         Selection.Merge
         i = i + 1
         basla = i
         eskisayi = Cells(i, 3).Value
         eskiisim = Cells(i, 4).Value
         GoTo son
       End If
 
       eskisayi = sayi
       eskiisim = isim
son:
    Next i
    Application.DisplayAlerts = True
    MsgBox ("İşlem tamamlandı.")
End Sub

Sub bir_satir_bos()
  sonsatir = Cells(Rows.Count, "A").End(3).Row
  For i = sonsatir To 3 Step -1
    sayi = Cells(i, 3).Value
    sayi2 = Cells(i - 1, 3).Value
    If sayi <> sayi2 Then
    satirsec = i & ":" & i
      Rows(satirsec).Select
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
      Selection.Borders(xlDiagonalDown).LineStyle = xlNone
      Selection.Borders(xlDiagonalUp).LineStyle = xlNone
      Selection.Borders(xlEdgeLeft).LineStyle = xlNone
      Selection.Borders(xlEdgeTop).LineStyle = xlNone
      Selection.Borders(xlEdgeBottom).LineStyle = xlNone
      Selection.Borders(xlEdgeRight).LineStyle = xlNone
      Selection.Borders(xlInsideVertical).LineStyle = xlNone
      Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
      kolonah = "A" & i & ":H" & i
      Range(kolonah).Select
      Selection.Borders(xlDiagonalDown).LineStyle = xlNone
      Selection.Borders(xlDiagonalUp).LineStyle = xlNone
      Selection.Borders(xlEdgeLeft).LineStyle = xlNone
      With Selection.Borders(xlEdgeBottom)
         .LineStyle = xlContinuous
         .ColorIndex = 0
         .TintAndShade = 0
         .Weight = xlThin
      End With
      Selection.Borders(xlEdgeRight).LineStyle = xlNone
      Selection.Borders(xlInsideVertical).LineStyle = xlNone
      Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
      Selection.Borders(xlDiagonalDown).LineStyle = xlNone
      Selection.Borders(xlDiagonalUp).LineStyle = xlNone
      Selection.Borders(xlEdgeLeft).LineStyle = xlNone
      With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
      End With
      With Selection.Borders(xlEdgeBottom)
          .LineStyle = xlContinuous
          .ColorIndex = 0
          .TintAndShade = 0
          .Weight = xlThin
      End With
      Selection.Borders(xlEdgeRight).LineStyle = xlNone
      Selection.Borders(xlInsideVertical).LineStyle = xlNone
      Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
      Range("B19").Select
  End If
  Next i
End Sub

 

[ASLAN7410]

Sayın asri ilginiz için çok teşekkür ederim, ellerinize sağlık kodlar güzel çalışıyor ancak küçük bir sorun var,
Sayfa1'deki bilgiler Sayfa2'ye karışık geliyor, örneğin D sütunundaki isimlerde önce DDDDD-AAAAA-BBBBB-CCCCC şeklinde geliyor.

Bilgiler bu şekilde aktarıldığı zaman sıralama yapmak istediğimde hücreler birleşik olduğu için izin vermiyor.

Kodu 50.000 satırın üzerinde olan orijinal veri sayfasına uygulayıp
çalıştırdığımda sayfa kilitleniyor. Yarım saati geçti hala sayfa açılmadı.

Sayfa1'deki veriler aynen Sayfa2'ye aktarıldığında sıralama karışmadan hücreler birleştirilebilir mi?

 

[Asri]

Meajımdaki link güncellendi.

 

[ASLAN7410]

Sayın asri göndermiş olduğunuz örnekte kodlar gayet güzel çalışıyor, ellerinize sağlık. Hafta sonu olduğu için yarın iş yerine gittiğim zaman kodları orijinal dosyamda deneyip geri dönüş yapacağım.

Hayırlı kandiller.

 

[ASLAN7410]

Sayın asri sonradan gönderdiğin kodu orijinal sayfama uyguladım, tam istediğim verimi aldım.

Ellerinize sağlık çok teşekkür ederim, Allah razı olsun. Hayırlı kandiller dilerim.

 

[Asri]

Sayın asri sonradan gönderdiğin kodu orijinal sayfama uyguladım, tam istediğim verimi aldım.

Ellerinize sağlık çok teşekkür ederim, Allah razı olsun. Hayırlı kandiller dilerim.

Hayırlı kandiller,

Saygılar.