DAMGA (10) lu Hücrede Düşeyara

leonadies · 6 Nisan 2020

Üstadlar Merhaba;

Resimde görüldüğü gibi. K:L sütununda var olan bilgileri düşeyara mantığında P sütununda DAMGA(10) ile yazılmış karşılıklarına makro ile yazdırmak istiyorum. P Sütununda var olan siyah yazıların orada var olduğunu kabul edeceğiz.(çünkü duruma göre p2 de de olabiliyor p350 de olabiliyor. O kısım bende kısacası)
Makromuz ise sadece tüm P: P sütunu okuyup hangi hücrede bulduysa karşısına getirecek. Ulaşmak istediğimiz nihai hedef kırmızı yazılardır.

Korhan Ayhan · 7 Nisan 2020

Deneyiniz.

C++:

Option Explicit

Sub Damga_Onlu_Hucrede_Duseyara()
    Dim Dizi As Object, VB_RegExp As Object, Son As Long, Veri As Variant, X As Long, Y As Integer
    Dim Metin As Variant, Aranan As Variant, Liste As Variant, Say As Long, Zaman As Double

    Zaman = Timer

    Set Dizi = CreateObject("Scripting.Dictionary")
    Set VB_RegExp = CreateObject("VBScript.RegExp")
    
    VB_RegExp.IgnoreCase = True
    VB_RegExp.Global = True
    VB_RegExp.Pattern = " [^\D]+"
 
    Son = Cells(Rows.Count, "K").End(3).Row
    Veri = Range("K1:L" & Son).Value
    
    For X = LBound(Veri) To UBound(Veri)
        Dizi.Item(Veri(X, 1)) = Veri(X, 2)
    Next
    
    Son = Cells(Rows.Count, "P").End(3).Row
    Veri = Range("P1:P" & Son).Value
    
    ReDim Liste(1 To UBound(Veri), 1 To 1)
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 1) <> "" Then
            Metin = Split(Veri(X, 1), Chr(10))
            Say = Say + 1
            For Y = LBound(Metin) To UBound(Metin)
                If Metin(Y) <> "" Then
                    Aranan = VB_RegExp.Replace(Metin(Y), "")
                    If Dizi.Exists(Aranan) Then
                        If Liste(Say, 1) = "" Then
                            Liste(Say, 1) = Aranan & " " & Dizi.Item(Aranan)
                        Else
                            Liste(Say, 1) = Liste(Say, 1) & Chr(10) & Aranan & " " & Dizi.Item(Aranan)
                        End If
                    End If
                End If
            Next
        Else
            Say = Say + 1
            Liste(Say, 1) = Empty
        End If
    Next
    
    Range("P1").Resize(Say, 1) = Liste

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

muygun · 7 Nisan 2020

Merhaba;
P Sütununda var olan siyah yazıların orada var olduğunu kabul edeceğiz.(çünkü duruma göre p2 de de olabiliyor p350 de olabiliyor. O kısım bende kısacası)
Bu kısmı anlamadım ama yinede eki deneyin.
İyi çalışmalar.

leonadies · 7 Nisan 2020

@Korhan Ayhan çok teşekkür ederim. Tam istediğim gibi. 2 Tane çok önemli konumu çözdünüz. Ne kadar teşekkür etsem azdır

leonadies · 7 Nisan 2020

@muygun yani p sütununa yazıları elle ben gireceğim Makro L sütununda var olan karşılıklarını hemen yanına getirecek şeklinde anlatmaya çalıştım.

leonadies · 7 Nisan 2020

@Korhan Ayhan hocam şimdi fark ettim. K sütunundaki kelime sayısı 4 ve üzeri olan yeni veriler ekleyip sorgulama yapınca yada kelime aralarına rakam girince sorun yapıyor. Onu düzeltme şansımız olabilir mi?

Korhan Ayhan · 7 Nisan 2020

Lütfen örnek verir misiniz?

leonadies · 7 Nisan 2020

Ekledim @Korhan Ayhan hocam sarı renkleri transferde sorun yapıyor.

Korhan Ayhan · 7 Nisan 2020

Sorun ilçelerin içinde kullanılan sayısal değerlerden kaynaklanıyor.

Ben butona ikinci kez basışta kod sıkıntı çıkarmasın diye ilk olarak verideki sayısal verileri sildirip sonra tekrar ekletme yöntemini tercih ettim. Aslında verilerde sayı olabileceği aklıma geldi ama şansımı denemek istedim.

Birleştirme işareti olarak arada farklı bir karakter kullanmamız sıkıntı yaratmaz derseniz kolay şekilde çözebiliriz. Diğer türlü butona bir kez tıklamanız gerekecek.

Örneğin aşağıdaki gibi görüntü sıkıntı çıkarmaz derseniz kolayca çözüm üretebiliriz.

İstanbul Bağcılar 1 / 00666

leonadies · 7 Nisan 2020

Anladım Korhan Bey. Çalışmama yakın benzer örneklerle derdimi anlatmaya çalışıyorum her zaman. Normalde K sütununda sayısal veri olması gerekecek. Çözüm sıkıntı oluyorsa ayraç kullanmayı da yapabiliriz ozaman sorun yok

Korhan Ayhan · 7 Nisan 2020

Deneyiniz.

Ben ayraç olarak " / " sembolünü tercih ettim. Siz dilerseniz kod içinde ilgili yerlerden değiştirebilirsiniz.

C++:

Option Explicit

Sub Damga_Onlu_Hucrede_Duseyara()
    Dim Dizi As Object, Son As Long, Veri As Variant, X As Long, Y As Integer, Bul As Byte
    Dim Metin As Variant, Aranan As Variant, Liste As Variant, Say As Long, Zaman As Double

    Zaman = Timer

    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = Cells(Rows.Count, "K").End(3).Row
    Veri = Range("K1:L" & Son).Value2
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 2) <> "" Then Dizi.Item(Veri(X, 1)) = Format(Veri(X, 2), "00000")
    Next
    
    Son = Cells(Rows.Count, "P").End(3).Row
    Veri = Range("P1:P" & Son).Value
    
    ReDim Liste(1 To UBound(Veri), 1 To 1)
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 1) <> "" Then
            Metin = Split(Veri(X, 1), Chr(10))
            Say = Say + 1
            For Y = LBound(Metin) To UBound(Metin)
                If Metin(Y) <> "" Then
                    Bul = InStr(1, Metin(Y), " / ")
                    If Bul > 0 Then
                        Aranan = Left(Metin(Y), Bul - 1)
                    Else
                        Aranan = Metin(Y)
                    End If
                    If Dizi.Exists(Aranan) Then
                        If Liste(Say, 1) = "" Then
                            Liste(Say, 1) = Aranan & " / " & Dizi.Item(Aranan)
                        Else
                            Liste(Say, 1) = Liste(Say, 1) & Chr(10) & Aranan & " / " & Dizi.Item(Aranan)
                        End If
                    Else
                        If Liste(Say, 1) = "" Then
                            Liste(Say, 1) = Aranan
                        Else
                            Liste(Say, 1) = Liste(Say, 1) & Chr(10) & Aranan
                        End If
                    End If
                End If
            Next
        Else
            Say = Say + 1
            Liste(Say, 1) = Empty
        End If
    Next
    
    Range("P1").Resize(Say, 1) = Liste

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

leonadies · 7 Nisan 2020

Ellerine sağlık @Korhan Ayhan hocam. Çok güzel olmuş

leonadies · 8 Nisan 2020

@Korhan Ayhan hocam. Bu yazdığınız makro çok işime yaradı tekrar teşekkür ediyorum size. Yapılabilirse bir küçük ricam daha olacak. K: L sütunlarımız yine aynı kalmak koşuluyla sorgulama işlemleri birden çok sütunda aynı şekilde yapılabilir mi? Bu sütunları makrodan sadece düzeltme methodu ile benim belirleyeceğim bir yapıda yapılabilir mi? Örneğin P sütununda; T sütununda Y sütununda Z sütununda aynı anda aynı mantıkta sorgulama yapabilme şeklinde

Korhan Ayhan · 8 Nisan 2020

Deneyiniz.

C++:

Option Explicit

Sub Damga_Onlu_Hucrede_Duseyara()
    Dim Sutun As Variant, Dizi As Object, Sutun_Kontrol As Object, Son As Long, Veri As Variant, X As Long, Y As Integer
    Dim Z As Integer, Bul As Byte, Metin As Variant, Aranan As Variant, Liste As Variant, Say As Long, Zaman As Double
    
    Sutun = Application.InputBox("K ve L sütunları dışında işlem yapmak istediğiniz sütunları yazınız." & Chr(10) & _
            "Aralarına virgül ekleyerek sütun harflerini yazınız." & Chr(10) & Chr(10) & _
            "Örnek ; A,B,C,D,E,F", "İşlem Yapılacak Sütun Bilgileri")
    
    If Sutun = False Or Sutun = "" Then
        MsgBox "İşleme devam edebilmeniz için sütun bilgilerini girmelisiniz!", vbCritical
        Exit Sub
    End If
    
    Zaman = Timer

    Set Dizi = CreateObject("Scripting.Dictionary")
    Set Sutun_Kontrol = CreateObject("Scripting.Dictionary")
    
    Son = Cells(Rows.Count, "K").End(3).Row
    Veri = Range("K1:L" & Son).Value2
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 2) <> "" Then Dizi.Item(Veri(X, 1)) = Format(Veri(X, 2), "00000")
    Next
    
    If InStr(1, Sutun, ",") = 0 Then
        Sutun = Sutun & ","
    End If
    
    Sutun = Split(Sutun, ",")
    
    For X = LBound(Sutun) To UBound(Sutun)
        If Sutun(X) <> "" Then
            On Error Resume Next
            If IsError(Cells(1, Sutun(X)).Column) Then GoTo 10
            On Error GoTo 0
            If UCase(Sutun(X)) = "K" Or UCase(Sutun(X)) = "L" Then GoTo 10
            If Not Sutun_Kontrol.Exists(Sutun(X)) Then
                Sutun_Kontrol.Add Sutun(X), Nothing
            
                Son = Cells(Rows.Count, Sutun(X)).End(3).Row
                If Son = 1 Then Son = Son + 1
                Veri = Cells(1, Sutun(X)).Resize(Son).Value
    
                ReDim Liste(1 To UBound(Veri), 1 To 1)
    
                For Y = LBound(Veri) To UBound(Veri)
                    If Veri(Y, 1) <> "" Then
                        Metin = Split(Veri(Y, 1), Chr(10))
                        Say = Say + 1
                        For Z = LBound(Metin) To UBound(Metin)
                            If Metin(Z) <> "" Then
                                Bul = InStr(1, Metin(Z), " / ")
                                If Bul > 0 Then
                                    Aranan = Left(Metin(Z), Bul - 1)
                                Else
                                    Aranan = Metin(Z)
                                End If
                                If Dizi.Exists(Aranan) Then
                                    If Liste(Say, 1) = "" Then
                                        Liste(Say, 1) = Aranan & " / " & Dizi.Item(Aranan)
                                    Else
                                        Liste(Say, 1) = Liste(Say, 1) & Chr(10) & Aranan & " / " & Dizi.Item(Aranan)
                                    End If
                                Else
                                    If Liste(Say, 1) = "" Then
                                        Liste(Say, 1) = Aranan
                                    Else
                                        Liste(Say, 1) = Liste(Say, 1) & Chr(10) & Aranan
                                    End If
                                End If
                            End If
                        Next
                    Else
                        Say = Say + 1
                        Liste(Say, 1) = Empty
                    End If
                Next
            End If
        End If
        
        If Say > 0 Then
            Cells(1, Sutun(X)).Resize(Say, 1) = Liste
            Say = 0
            Erase Liste
        End If
10  Next
    
    Set Dizi = Nothing
    Set Sutun_Kontrol = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

leonadies · 9 Nisan 2020

@Korhan Ayhan ellerinize sağlık hocam.Gerçekten çok işlevsel olmuş. Ancak bu şekilde sürekli sormasını pek tercih etmemem gerekecek.nünde arkasında çalışacak başka makrolarım var çünkü. Böyle yapmak yerine makro içinde sütunları yazacağım yerler bırakırsanız daha mutlu olurum. Ama söylemeden geçemeyeceğim. Gerçekten çok güzel olmuş bu yaptığınız

Korhan Ayhan · 9 Nisan 2020

Aşağıdaki gibi deneyiniz.

C++:

Option Explicit

Sub Damga_Onlu_Hucrede_Duseyara()
    Dim Sutun As Variant, Dizi As Object, Son As Long, Veri As Variant, X As Long, Y As Integer
    Dim Z As Integer, Bul As Byte, Metin As Variant, Aranan As Variant, Liste As Variant, Say As Long, Zaman As Double
    
    Zaman = Timer

    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = Cells(Rows.Count, "K").End(3).Row
    Veri = Range("K1:L" & Son).Value2
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 2) <> "" Then Dizi.Item(Veri(X, 1)) = Format(Veri(X, 2), "00000")
    Next
    
    Sutun = Array("P", "T", "Y", "Z")
    
    For X = LBound(Sutun) To UBound(Sutun)
        Son = Cells(Rows.Count, Sutun(X)).End(3).Row
        If Son = 1 Then Son = Son + 1
        Veri = Cells(1, Sutun(X)).Resize(Son).Value
    
        ReDim Liste(1 To UBound(Veri), 1 To 1)
    
        For Y = LBound(Veri) To UBound(Veri)
            If Veri(Y, 1) <> "" Then
                Metin = Split(Veri(Y, 1), Chr(10))
                Say = Say + 1
                For Z = LBound(Metin) To UBound(Metin)
                    If Metin(Z) <> "" Then
                        Bul = InStr(1, Metin(Z), " / ")
                        If Bul > 0 Then
                            Aranan = Left(Metin(Z), Bul - 1)
                        Else
                            Aranan = Metin(Z)
                        End If
                        If Dizi.Exists(Aranan) Then
                            If Liste(Say, 1) = "" Then
                                Liste(Say, 1) = Aranan & " / " & Dizi.Item(Aranan)
                            Else
                                Liste(Say, 1) = Liste(Say, 1) & Chr(10) & Aranan & " / " & Dizi.Item(Aranan)
                            End If
                        Else
                            If Liste(Say, 1) = "" Then
                                Liste(Say, 1) = Aranan
                            Else
                                Liste(Say, 1) = Liste(Say, 1) & Chr(10) & Aranan
                            End If
                        End If
                    End If
                Next
            Else
                Say = Say + 1
                Liste(Say, 1) = Empty
            End If
        Next
        
        If Say > 0 Then
            Cells(1, Sutun(X)).Resize(Say, 1) = Liste
            Say = 0
            Erase Liste
        End If
    Next
    
    Set Dizi = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

leonadies · 9 Nisan 2020

Çok ama çok teşekkür ederim @Korhan Ayhan hocam. Ellerinize sağlık

Korhan Ayhan · 9 Nisan 2020

Next ifadesinden önceki 10 değerini silebilirsiniz. Düzenlerden unutmuşum.

Ben önceki mesajımda düzelttim.

leonadies · 10 Nisan 2020

@Korhan Ayhan hocam son sorunum şu şekilde
=EĞER(YADA(A2="";B2="");"";"OK")
şeklinde size temsili olarak sunduğum bu formülün sonucunu AA sütununda cevabı "" (boş olarak) çeviren sütunlarda aşağıdaki hatayla karşılaşıyorum. ama sütundaki boş satırları elimle DELETE yapıp temizlersem makro sorunsuz çalışıyor ya da başka bir sebep var tesadüfen oluyor bilemiyorum.
For Y = LBound(Veri) To UBound(Veri)

Korhan Ayhan · 13 Nisan 2020

Hata veren örnek dosya paylaşırsanız inceleme fırsatımız olur.

DAMGA (10) lu Hücrede Düşeyara

Excel Derya Deniz Bizde Kulaç Atmaya Çalışıyoruz:)

Ekli dosyalar

Administrator

Özel Üye

Ekli dosyalar

Excel Derya Deniz Bizde Kulaç Atmaya Çalışıyoruz:)

Excel Derya Deniz Bizde Kulaç Atmaya Çalışıyoruz:)

Excel Derya Deniz Bizde Kulaç Atmaya Çalışıyoruz:)

Administrator

Excel Derya Deniz Bizde Kulaç Atmaya Çalışıyoruz:)

Ekli dosyalar

Administrator

Excel Derya Deniz Bizde Kulaç Atmaya Çalışıyoruz:)

Administrator

Excel Derya Deniz Bizde Kulaç Atmaya Çalışıyoruz:)

Excel Derya Deniz Bizde Kulaç Atmaya Çalışıyoruz:)

Administrator

Excel Derya Deniz Bizde Kulaç Atmaya Çalışıyoruz:)

Administrator

Excel Derya Deniz Bizde Kulaç Atmaya Çalışıyoruz:)

Administrator

Excel Derya Deniz Bizde Kulaç Atmaya Çalışıyoruz:)

Administrator