Son boş hücreye kadar arayıp sarı renge boyama

[mdemirgiller]

arkadaşlar iyi günler
öncelikle sorunuma yardım edebilirseniz gerçekten çok sevineceğim...
durumum şöyle:
iki adet workbook ta çalışıyorm. birincisinde 1 adet worksheet diğerinde 3 adet worksheet var.
ben ilk workbooktaki d1 hücresindeki şirket adının baştan belli bir karakter sayısının ( 8-10 gibi) okunup bunun diğer workbooktaki her worksheet de aranıp,o workbookta bulunması halinde ilk workbook a geri dönülüp arattığım hücreyi sarıya boyatmak ve bir alttaki hücreye geçip aynı işlemi enson boş hücreye gelene kadar sürdürmek istiyorum.

qbasic biliyorum ancak vbasic le makro yazmak qbasic dilinden farklı olduğu için kilitlendim kaldım..yardımlarınızı bekliyorum

çok çok teşekkürler

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu boş bir modüle uygulayıp denermisiniz.

İki kitabınızda aynı yerde olmalı. Ayrıca kitap isilerinizi belirtmedğiniz için örnek isimler kullandım. Koddaki kırmızı bölümleri kendinize göre değiştirmeyi unutmayınız.

Kitap2 arama yapılacak kitabı ifade etmektedir. Sayfa1 ise tek sayfa bulunan kitabınızdaki sayfa adını ifade etmektedir. Düzeltmelerinizi bu yönde yapınız.

Arama işlemi ilk 8 karaktere göre yapılmaktadır. Eğer veri karakter sayısı 8 karakterden az ise verinin tamamı arama işleminde kullanılmaktadır.

Option Explicit
 
Sub DİĞER_KİTAPTA_ARA()
    Dim K1 As Workbook, K2 As Workbook
    Dim X As Long, ARANAN_VERİ As String, Y As Byte, BUL As Range
 
    Set K1 = ThisWorkbook
    Set K2 = Workbooks.Open(ThisWorkbook.Path & "\[COLOR=red]Kitap2.xls[/COLOR]", False, False)
 
    K1.Activate
 
    Columns(4).Interior.ColorIndex = xlNone
 
    With K1
        For X = 1 To .Sheets("[COLOR=red]Sayfa1[/COLOR]").Range("D65536").End(3).Row
            If .Sheets("[COLOR=red]Sayfa1[/COLOR]").Cells(X, "D") <> "" Then
            If Len(.Sheets("[COLOR=red]Sayfa1[/COLOR]").Cells(X, "D")) >= 8 Then
            ARANAN_VERİ = Left(.Sheets("[COLOR=red]Sayfa1[/COLOR]").Cells(X, "D"), 8)
            Else
            ARANAN_VERİ = .Sheets("[COLOR=red]Sayfa1[/COLOR]").Cells(X, "D")
            End If
 
                For Y = 1 To K2.Sheets.Count
                    Set BUL = K2.Sheets(Y).Cells.Find(ARANAN_VERİ)
                    If Not BUL Is Nothing Then
                    .Sheets("[COLOR=red]Sayfa1[/COLOR]").Cells(X, "D").Interior.ColorIndex = 3
                    End If
                Next
            End If
        Next
 
        K2.Close True
 
    End With
 
    Set BUL = Nothing
    Set K1 = Nothing
    Set K2 = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[mdemirgiller]

çok teşekkür ederim çalıştığım kitap biraz büyük olduğundan hala işlem yapıyor.sonucu bildireceğim umarım olumlu olur.elinize sağlık tekrar çok teşekkür ederim

 

[mdemirgiller]

şmdi bitti programın çalışması.öncelikle işimi epey hafifletti bunun için çok teşekkür ederim.ancak birkaç sorum daha olacak,

öncelikle bu yaptığımız aramada büyük-küçük harf farklılığı etki edermi?

bir de bazı bilgileri software database inden aldığım için bazı yerlerde İ yerine I kullanılmış ve bu da arama sonuçlarını etkiliyor haliyle.Bunun için gördüğümüz bütün i leri ı ya çevirebilme imkanımız varmı acaba?

çok zahmet oldu size,değerli zamanınızı aldığım için tekrardan özür dilerim.

teşekkürler

 

[Korhan Ayhan]

Selamlar,

Arama işlemi büyük-küçük harf duyarlı değildir.

ARANAN_VERİ değişkenindeki (yani D sütunundaki verileri) "i" harflerini "ı" harfine çevirerek daha doğru bir arama yapmasını sağlayabiliriz.

Eğer bahsettiğim şekilde işinize yarıyacaksa bildirirseniz kodu düzenleyebilirim.

 

[mdemirgiller]

Size soruyu sorduktan sonra zaten deneme yanılma yöntemiyle farkettim i,ç,ö,ğ,ş,ü duyarlı olduğunu ve bul/değiştir yaparak iki kitaptaki türkçe harfleri ı,c,o,g,s,u haline getirdim. ancak ilerde daha fazla veriyle çalışacağımdan gerekli kodu da yapabilirsek gerçekten çok sevineceğim. birde sarıya değil kırmızıya boyuyor sarı renk kodunu aradım ancak onu da bulamadım..

emeğiniz için çok çok teşekkür ederim.
iyi çalışmalar

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub DİĞER_KİTAPTA_ARA()
    Dim K1 As Workbook, K2 As Workbook
    Dim X As Long, ARANAN_VERİ As String, Y As Byte, BUL As Range
    Dim ESKİ_HARFLER As Variant, YENİ_HARFLER As Variant, HARF As Byte
    
    ESKİ_HARFLER = Array("i", "İ", "ç", "Ç,", "ğ", "Ğ", "ö", "Ö", "ş", "Ş", "ü", "Ü")
    YENİ_HARFLER = Array("ı", "I", "c", "C,", "g", "G", "o", "O", "s", "S", "u", "U")
    
    Set K1 = ThisWorkbook
    Set K2 = Workbooks.Open(ThisWorkbook.Path & "\Kitap2.xls", False, False)
    K1.Activate
    
    Columns(4).Interior.ColorIndex = xlNone
    
    For HARF = 0 To UBound(ESKİ_HARFLER)
        Columns("D:D").Replace What:=ESKİ_HARFLER(HARF), Replacement:=YENİ_HARFLER(HARF), _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True, _
        SearchFormat:=False, ReplaceFormat:=False
    Next
    
    With K1
        For X = 1 To .Sheets("Sayfa1").Range("D65536").End(3).Row
            If .Sheets("Sayfa1").Cells(X, "D") <> "" Then
            If Len(.Sheets("Sayfa1").Cells(X, "D")) >= 8 Then
            ARANAN_VERİ = Left(.Sheets("Sayfa1").Cells(X, "D"), 8)
            Else
            ARANAN_VERİ = .Sheets("Sayfa1").Cells(X, "D")
            End If
            
                For Y = 1 To K2.Sheets.Count
                    For HARF = 0 To UBound(ESKİ_HARFLER)
                        K2.Sheets(Y).Cells.Replace What:=ESKİ_HARFLER(HARF), Replacement:=YENİ_HARFLER(HARF), _
                        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True, _
                        SearchFormat:=False, ReplaceFormat:=False
                    Next
                    
                    Set BUL = K2.Sheets(Y).Cells.Find(ARANAN_VERİ)
                    If Not BUL Is Nothing Then
                    .Sheets("Sayfa1").Cells(X, "D").Interior.ColorIndex = 6
                    End If
                Next
            End If
        Next
        
        K2.Close True
    
    End With
    
    Set BUL = Nothing
    Set K1 = Nothing
    Set K2 = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[mdemirgiller]

teşekkür ederim

verdiğiniz kod istediğim işi yaptı teşekkür ederim tekrar elinize sağlık