Tanıtım

Excelde “Böl, Bul ve Renklendir” Makrosu

ugurumsuComment(0)

İş yerinde kontrol etmem gereken bir veri serisinde işimi kolaylaştırmak için excele başvurmaya karar verdiğimde niyetim işlevler ile işimi halletmekti. İşin içinden çıkamayınca hazır makrolarla yapmayı denedim ve bazı internet sitelerinde bulduğum makroları düzenleyerek istediğim işlemi yapabildim.

Makro kodlarını yazmadan önce yapmaya çalıştığım işlemi anlatayım. İlk veri setim “bb cc dd …” şeklinde devam ediyor. Buna A verisi diyelim. Benim için önemli veriler “dd” kısmıydı. Yani ikinci boşlukla üçüncü boşluk arası olan veriler. Bundan dolayı ilk yapmak gereken “Metni Sütunlara Dönüştür” işlemiydi. 

Range("B1:S65536").Select
    Selection.ClearContents
For n = 1 To Range("A65536").End(xlUp).Row
kolon = Split(Cells(n, 1).Value, " ")
For i = 0 To UBound(kolon)
Cells(n, i + 2).Value = kolon(i)
Next
Next

Kodu açıklamaya çalışsam beceremem. Ama anladığım kadarıyla anlatayım. “Range(B1:S65536″).Select” kodu B1 hücresi ile S65536 arasındaki tüm sütunları seçiyor. “Selection.ClearContents” kodu yapılan seçimin tamamını temizliyor. Sonraki kod dizisi ise kabaca her bir hücrenin +1 sütunundaki hücreye boşluktan önceki parçayı bırak. Diğer bir deyişle “Metni Sütunlara Dönüştür” işleminde ayırıcı olarak “Boşluk” seçimi yapılmış. Kod dizisi içindeki “kolon = Split(Cells(n, 1).Value, ” “)” kısmındaki çift tırnak arasındaki boşluk bu seçimi göstermektedir.

A verisinin “bb cc dd ee ff gg hh ıı jj kk ll mm nn oo pp qq rr ss” şeklinde 17 boşluklu 18 parçadan oluştuğunu varsaydım. Bu nedenle B sütunundan S sütununa kadar boş bıraktım.

Sonraki işlemim ise A verisinin üçüncü kısmında olup olmadığına bakmam gereken verilerdi. Bu verilere de seri diyelim. Seriler için T sütunundan Z sütununa kadar yedi sütun ayırdım. Burada dikkat etmemiz gereken şey A verisinin en fazla 65536 adet olabileceği. Bu nedenle tek seferde işlem yapmak istiyorsak T sütunundan Z sütununa kadar toplam 65536’yı aşmayacak kadar seri yazmamız gerekiyor. Tabi bunun için farklı bir çözüm buldum ben.

sonT = Cells(Rows.Count, "T").End(3).Row
...

son = WorksheetFunction.Max(sonT, ...)
bul = 0

eski = MsgBox("Eski renklendirmeler iptal edilsin mi?", vbYesNo)

If eski = vbYes Then
    Range("T1:T" & sonT).Interior.Color = xlNone
    ...
End If

For Each hucre In Range("T1:T" & sonT)
    If WorksheetFunction.CountIf(Range("D1:D" & sonD), hucre) > 0 Then
        hucre.Interior.Color = vbRed
        bul = bul + 1
    End If
Next

...

Önce her bir sütuna kısa ad verdim. Sonrasında daha önceki renklendirmeleri kaldırıp kaldırmamayı sordum. Eğer A verisini serinin tamamının arka planı kırmızı olana kadar değiştireceksek bu soruya hyır cevabı verilmelidir. Değilse “Evet” denilmeli ve renklendirme işlemi geri alınmalı. Sonrasında her bir “For Each” ile başlayan işlem her sütundaki veriyi D sütununda arıyor ve bulursa arka planını kırmızıya boyuyor.

If bul = 0 Then
    MsgBox "Aranan veriler bulunamamıştır!", vbInformation
Else
    MsgBox bul & " adet veri bulunup boyandı!", vbInformation
End If

Son kodlarda ise eğer herhangi bir seri ile A verisinin üçüncü kısmının eşleşmediği ya da eşleşti ise kaç tane eşleştiği bilgisi veriyor.

Son işlemim ise bu makro kodunu bir düğmeye tanımlamak oldu. Kodun son hali ise şu şekilde oldu:

Private Sub Düğme1_Tıkla()

Range("B1:S65536").Select
    Selection.ClearContents
For n = 1 To Range("A65536").End(xlUp).Row
kolon = Split(Cells(n, 1).Value, " ")
For i = 0 To UBound(kolon)
Cells(n, i + 2).Value = kolon(i)
Next
Next

sonT = Cells(Rows.Count, "T").End(3).Row
sonU = Cells(Rows.Count, "U").End(3).Row
sonV = Cells(Rows.Count, "V").End(3).Row
sonW = Cells(Rows.Count, "W").End(3).Row
sonX = Cells(Rows.Count, "X").End(3).Row
sonY = Cells(Rows.Count, "Y").End(3).Row
sonZ = Cells(Rows.Count, "Z").End(3).Row
sonD = Cells(Rows.Count, "D").End(3).Row

son = WorksheetFunction.Max(sonT, sonU, sonV, sonW, sonX, sonY, sonZ)
bul = 0

eski = MsgBox("Eski renklendirmeler iptal edilsin mi?", vbYesNo)

If eski = vbYes Then
    Range("T1:T" & sonT).Interior.Color = xlNone
    Range("U1:U" & sonT).Interior.Color = xlNone
    Range("V1:V" & sonT).Interior.Color = xlNone
    Range("W1:W" & sonT).Interior.Color = xlNone
    Range("X1:X" & sonT).Interior.Color = xlNone
    Range("Y1:Y" & sonT).Interior.Color = xlNone
    Range("Z1:Z" & sonT).Interior.Color = xlNone
End If

For Each hucre In Range("T1:T" & sonT)
    If WorksheetFunction.CountIf(Range("D1:D" & sonD), hucre) > 0 Then
        hucre.Interior.Color = vbRed
        bul = bul + 1
    End If
Next

For Each hucre In Range("U1:U" & sonU)
    If WorksheetFunction.CountIf(Range("D1:D" & sonD), hucre) > 0 Then
        hucre.Interior.Color = vbRed
        bul = bul + 1
    End If
Next

For Each hucre In Range("V1:V" & sonV)
    If WorksheetFunction.CountIf(Range("D1:D" & sonD), hucre) > 0 Then
        hucre.Interior.Color = vbRed
        bul = bul + 1
    End If
Next

For Each hucre In Range("W1:W" & sonW)
    If WorksheetFunction.CountIf(Range("D1:D" & sonD), hucre) > 0 Then
        hucre.Interior.Color = vbRed
        bul = bul + 1
    End If
Next

For Each hucre In Range("X1:X" & sonX)
    If WorksheetFunction.CountIf(Range("D1:D" & sonD), hucre) > 0 Then
        hucre.Interior.Color = vbRed
        bul = bul + 1
    End If
Next

For Each hucre In Range("Y1:Y" & sonY)
    If WorksheetFunction.CountIf(Range("D1:D" & sonD), hucre) > 0 Then
        hucre.Interior.Color = vbRed
        bul = bul + 1
    End If
Next

For Each hucre In Range("Z1:Z" & sonZ)
    If WorksheetFunction.CountIf(Range("D1:D" & sonD), hucre) > 0 Then
        hucre.Interior.Color = vbRed
        bul = bul + 1
    End If
Next

If bul = 0 Then
    MsgBox "Aranan veriler bulunamamıştır!", vbInformation
Else
    MsgBox bul & " adet veri bulunup boyandı!", vbInformation
End If

End Sub

Tabi bu makroları çeşitli forumlarda bulup kendimce ufak tefek değişiklikler yaparak birleştirdim ve yazdım. Bunların bağlantılarını yazı sonunda paylaştım.

Umarım işinize yarayan bir içerik olmuştur.

ExcelVBA Forumunda yararlandığım yanıt: http://www.excelvba.net/viewtopic.php?t=5590#p130640

Excel.Web.Tr Forumunda yararlandığım yanıt: https://www.excel.web.tr/threads/belirli-kelime-ve-rakamlari-iki-suetunda-bul-renklendir.186646/#post-1031600