İçeriği Aynı olan Hücreleri Birleştirmek..!

[sensizsoldum]

Merhaba,
C3:C sütun aralığında rakamsal veriler var, aşağıda verdiğim kod ile bu sütun aralığında ki verilerden aynı olanları birleştiriyor. Kod yavaş değil, ama yavaş çalışıyor. Örneğin tek seferde 150 kadar veri ekliyorum. Bunu birleştiriyorum daha sonra yine veri ekliyorum ve bu kez yavaşlama oluyor. Sayı arttıkça veri birleşmesi yavaşlıyor. Şu an yaklaşık 5000 kadar veri var zamanla çoğalacak ve ciddi yavaşlamalar olacaktır. Bu koda atıyorum son birleştirme 3500 hücrede bitti. Bir sonraki işlemi buradan başlatıp yaptırabilir miyiz? Ya da bu kodu farklı şekilde yazarak daha hızlı bir çalışma sağlayabilir miyiz?


Sub merge()
Application.DisplayAlerts = False
For i = Range("C65536").End(3).Row To 2 Step -1
If Cells(i, 3) = Cells(i - 1, 3) Then
Range(Cells(i, 3), Cells(i - 1, 3)).merge
End If
Next
Application.DisplayAlerts = True
End Sub

 

[uzmanamele]

Merhaba
Aşağıdaki kod ile C sütununda son birleştirilmiş hücrenin satır numarasını bulun.
Bu satır numarasını kendi kodunuzda kullanın

Sub mergem()
For j = Range("C65536").End(3).Row To 1 Step -1
If Cells(j, "C").MergeCells = True Then
MsgBox j
Exit For
End If
Next
End Sub

For i = Range("C65536").End(3).Row To j Step -1

 

[sensizsoldum]

Sayın uzman hocam
İlginiz için teşekkürler ama bu yazdığınız kod ile neyi bulacağım anlamadım ben üsteki verdiğiniz kodla bende o kodu değişirdim. Butonu tıklıyorum 5730 rakamı geliyor. Pek bir şey anlamadım açıkçası. Biraz daha kapsamlı anlatabilir misiniz?
Saygılarımla.

 

[uzmanamele]

Merhaba

Bu mudur?

Sub merge()
Application.DisplayAlerts = False


For j = Range("C65536").End(3).Row To 1 Step -1
If Cells(j, "C").MergeCells = True Then
MevcutSonMerge = j
Exit For
End If
Next


For i = Range("C65536").End(3).Row To MevcutSonMerge Step -1
If Cells(i, 3) = Cells(i - 1, 3) Then
Range(Cells(i, 3), Cells(i - 1, 3)).merge
End If
Next
Application.DisplayAlerts = True
End Sub

 

[sensizsoldum]

Merhaba,
Sayın uzman hocam birkaç küçük denemeler yaptım istenilen bir şekilde çalışıyor. Birde gerçek çalışmalarda bakalım ne olacak. İlgi ve alakalarınıza sonsuz teşekkür ederim. İyi çalışmalar dilerim.

 

[sensizsoldum]

Merhaba
Sayın uzman hocam bir üstteki veriyi kaldığı yerden birleştirme işlemi çok hızlı ve güzel oldu. Rahat bir şekilde artık işlemi yapıyorum. Buna benzer çalışma aşağıda verdiğim kodda da geçerli kaldığı yerden silme işlemi yapmak istiyorum, bu sayede hızlı bir şekilde silme işlemi yapmış olacağım. Bu koda da yardımcı olursanız daha çok memnun olacağım. İyi akşamlar dilerim.
Saygılarımla.



Sub Gelenlerden_sil()
Dim sonGonderilen As Long, sonGelen As Long, i As Long, f As Range

sonGonderilen = Range("b65536").End(3).Row
sonGelen = Sayfa2.Range("b65536").End(3).Row

For i = 3 To sonGonderilen
Set f = Sayfa2.Range("b2:b" & sonGelen).Find(Cells(i, "b"), lookat:=xlWhole)
If Not f Is Nothing Then
Cells(i, "a") = Sayfa2.Cells(f.Row, "a")
Sayfa2.Rows(f.Row).Delete
End If
Next
End Sub

 

[sensizsoldum]

Merhaba sayın uzman hocam,
Bir üst mesajdaki konuya da kaldığı yerden devam edecek bir özellik yapabilir miyiz? Diğer koda eklenen o özellikten çok memnunum. Bunu da o şekilde uyarlaya bilirsek çok sevinirim.
İyi çalışmalar dilerim.

 

[sensizsoldum]

Merhaba,
Arkadaşlar bu kod için de kaldığı yerden devam edecek bir özelliği nasıl yapabiliriz. Yardımcı olabilir misiniz? İyi çalışmalar dilerim.