[Çözüldü] Aynı değeri içeren satırları saçme

[drejan62]

Merhabalar,
Ekteki listede görüleceği gibi, G ve H sütunlarında aynı değerleri içeren satırları seçip paror sayfasına aktarabilirmiyiz.
Teşekkürler

[Forum yazılım güncelleme esnasında sorun oluştuğundan eklendi silinmiştir.]

[Bülent Öztürk]

Merhaba Ercan Bey,

Kodu bir düğmeye atayıp çalıştırın;

Kod: [Seç]

Sub Excelce_Aynilari_Bul_Aktar()
Dim excelce_borc As Range, excelce_alacak As Range
excelce_basla:
For Each excelce_borc In Worksheets("liste").Range("G2:G" & Worksheets("liste").Range("G65530").End(3).Row)
    If excelce_borc = 0 Then GoTo excelce_ileri
    For Each excelce_alacak In Worksheets("liste").Range("H2:H" & Worksheets("liste").Range("H65530").End(3).Row)
         If excelce_borc <> 0 And excelce_borc = excelce_alacak Then
            rapor_son = Worksheets("rapor").Range("A65530").End(3).Row + 1
            excelce_borc.EntireRow.Cut Worksheets("rapor").Range("A" & rapor_son)
            excelce_alacak.EntireRow.Cut Worksheets("rapor").Range("A" & rapor_son + 1)
        GoTo excelce_basla
        End If
    Next excelce_alacak
excelce_ileri:
Next excelce_borc
MsgBox "İşlem tamam.", vbInformation, "Excelce.Net"
End Sub


[drejan62]

Merhaba Ercan Bey,

Kodu bir düğmeye atayıp çalıştırın;

Teşekkürler Bülent bey harikasınız.
Çok önemli değil ama aynı olan satırları taşımak yerine kopyalasak olurmu acaba.
çok sağolun..

[Bülent Öztürk]

Rica ederim. Siz de sağolun.

Ayrıca, o sizin kendi harikalığınız.

Kopyalamak için;
Cut yazan yerleri Copy olarak değiştirin.
Ama aynı değerler varsa sorun çıkabilir.
Kopyalanan satırları, daha önce kopyalandığını belirtmek için işaretlettirmek gerekir.

 

[drejan62]

Rica ederim. Siz de sağolun.

Ayrıca, o sizin kendi harikalığınız.

Kopyalamak için;
Cut yazan yerleri Copy olarak değiştirin.
Ama aynı değerler varsa sorun çıkabilir.
Kopyalanan satırları, daha önce kopyalandığını belirtmek için işaretlettirmek gerekir.

Aman kalsın o zaman
teşekkürler tekrar

[Bülent Öztürk]

Şöyle bir şey yapılabilir;

Kod: [Seç]

Sub Excelce_Aynilari_Bul_Kopyala_Aktar()
Dim excelce_borc As Range, excelce_alacak As Range
For Each excelce_borc In Worksheets("liste").Range("G2:G" & Worksheets("liste").Range("G65530").End(3).Row)
    If excelce_borc = 0 Then GoTo excelce_ileri
    For Each excelce_alacak In Worksheets("liste").Range("H2:H" & Worksheets("liste").Range("H65530").End(3).Row)
         If excelce_borc <> 0 And excelce_borc = excelce_alacak And excelce_alacak.Font.Bold = False Then
            rapor_son = Worksheets("rapor").Range("A65530").End(3).Row + 1
            excelce_borc.EntireRow.Copy Worksheets("rapor").Range("A" & rapor_son)
            excelce_alacak.EntireRow.Copy Worksheets("rapor").Range("A" & rapor_son + 1)
            excelce_borc.Font.Bold = True
            excelce_alacak.Font.Bold = True
        End If
    Next excelce_alacak
excelce_ileri:
Next excelce_borc
MsgBox "İşlem tamam.", vbInformation, "Excelce.Net"
End Sub

Kopyalananları koyu yaparız, karşılaştırıken koyu olmayanlara bakarız. 

[drejan62]

Şöyle bir şey yapılabilir;

Kod: [Seç]

Sub Excelce_Aynilari_Bul_Kopyala_Aktar()
Dim excelce_borc As Range, excelce_alacak As Range
For Each excelce_borc In Worksheets("liste").Range("G2:G" & Worksheets("liste").Range("G65530").End(3).Row)
    If excelce_borc = 0 Then GoTo excelce_ileri
    For Each excelce_alacak In Worksheets("liste").Range("H2:H" & Worksheets("liste").Range("H65530").End(3).Row)
         If excelce_borc <> 0 And excelce_borc = excelce_alacak And excelce_alacak.Font.Bold = False Then
            rapor_son = Worksheets("rapor").Range("A65530").End(3).Row + 1
            excelce_borc.EntireRow.Copy Worksheets("rapor").Range("A" & rapor_son)
            excelce_alacak.EntireRow.Copy Worksheets("rapor").Range("A" & rapor_son + 1)
            excelce_borc.Font.Bold = True
            excelce_alacak.Font.Bold = True
        End If
    Next excelce_alacak
excelce_ileri:
Next excelce_borc
MsgBox "İşlem tamam.", vbInformation, "Excelce.Net"
End Sub

Kopyalananları koyu yaparız, karşılaştırıken koyu olmayanlara bakarız. 

Eyvallah üstad
sağol

[Bülent Öztürk]

Rica ederim.