Makro ile şartlı veri yazdırma

cedi007 · 28 Şubat 2021

selamlar,

ek'te belirtmiş olduğum dosyada A kolonundaki verilerin içerisinde, kendi belirleyeceğim şarta göre B kolonuna o veriyi yazmanı istiyorum. Şöyle ki;
A kolonunda "GL06_" , "SR06_" , "B06_" ile başlayan değerler için B kolonunda "ANKARA" yazsın. Bu değerleri içermeyen veriler için B sütununa değer yazdırmaya gerek.

Bunu makro ile yapmanın yöntemini sistemi kasmayacak şekilde bir kod parçası paylaşmanız mümkün müdür? Kasmayacak diyorum çünkü bu veriyi dosyası gerçeğinde 5K satır içeriyor.

teşekkürler.

https://dosya.co/cm1oud72nbdk/Book1.xlsx.html

Tevfik_Kursun · 1 Mart 2021

Merhaba,
Lütfen deneyiniz
https://dosya.co/v8bgvdidma5h/Book1_TK.xlsm.html
İyi çalışmalar

cedi007 · 1 Mart 2021

Tevfik bey, emeğinize sağlık çok başarılı.

Tevfik_Kursun · 2 Mart 2021

Rica ederim, dönüş yaptığınız için ben teşekkür ederim.
İyi çalışmalar

cedi007 · 27 Mart 2021

Tekrar Merhabalar,

Daha önce dönüş yapmıştınız bazı ihtiyaç duyduğum noktalarda kendime göre düzenleyip kullanıyorum.
Ek'te de belirttiğim gibi metinsel ve sayısal ifadelerin karışık olduğu bir hücredeki belirtmiş olduğum kelimeyi bulmasını nasıl sağlayabilirim.

Kodunuz şu aşamada çok başarılı olmuştu; eğer ki B hücresindeki değeri soldan parça alırken aranan kelimenin harfleri en soldan başlıyorsa çalışıyor. Ancak arada-en sağda vb. ise malesef çalışmıyor.

Nasıl yapabiliriz üstadlar

Korhan Ayhan · 27 Mart 2021

Deneyiniz.

C++:

Option Explicit

Sub Yazdir()
    Dim Son As Long, X As Long
    Son = Cells(Rows.Count, "B").End(3).Row
    'Columns("A:A").ClearContents
    For X = 2 To Son
        If InStr(1, Cells(X, 2), "RTN", vbTextCompare) > 0 Then
            Cells(X, 1) = "RTN"
        End If
    Next
End Sub

cedi007 · 27 Mart 2021

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Sub Yazdir()
    Dim Son As Long, X As Long
    Son = Cells(Rows.Count, "B").End(3).Row
    'Columns("A:A").ClearContents
    For X = 2 To Son
        If InStr(1, Cells(X, 2), "RTN", vbTextCompare) > 0 Then
            Cells(X, 1) = "RTN"
        End If
    Next
End Sub

Muhteşem

)) Teşekkürler Korhan bey.

cedi007 · 27 Mart 2021

Tekrardan Selamlar,

Ek'te dosya için makro ile bir nevi düşeyara yapılabilir mi, yoksa önerdiğiniz farklı bir yöntem var mıdır.
Yapmak istediğim; Sheet2 'dekileri Sheet1'dekiyle karşılaştırıp B ve C sütunlarına aynılarını yazmasını istiyroum

Teşekkürler.

Korhan Ayhan · 27 Mart 2021

Deneyiniz.

C++:

Option Explicit

Sub Fast_Vlookup()
    Dim Dizi As Object, S1 As Worksheet, S2 As Worksheet
    Dim Son As Long, Veri As Variant, X As Long
    Dim Aranan As String, Say As Long, Zaman As Double
    
    Zaman = Timer
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    Set S1 = Sheets("Sheet3")
    Set S2 = Sheets("Sheet2")
    
    S1.Range("B2:C" & S1.Rows.Count).ClearContents
    
    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
    If Son < 3 Then Son = 3
    
    Veri = S2.Range("A2:C" & Son).Value
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Aranan = UCase(Replace(Replace(Veri(X, 1), "ı", "I"), "i", "İ"))
        Dizi.Item(Aranan) = Veri(X, 2) & "|" & Veri(X, 3)
    Next


    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son < 3 Then Son = 3
    
    Veri = S1.Range("A2:C" & Son).Value
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Aranan = UCase(Replace(Replace(Veri(X, 1), "ı", "I"), "i", "İ"))
        If Dizi.Exists(Aranan) Then
            Veri(X, 2) = Split(Dizi.Item(Aranan), "|")(0)
            Veri(X, 3) = Split(Dizi.Item(Aranan), "|")(1)
        End If
    Next

    S1.Range("A2").Resize(UBound(Veri, 1), 3) = Veri
    S1.Columns.AutoFit
    
    Set Dizi = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

cedi007 · 27 Mart 2021

@korhan bey, emeğinize sağlık öncelikle. Ek'teki örnek dosya için uyguladım çalışma hızı mükemmel

Fakat aynı kodu farklı sayfa ve dosyalarda da kullanmak istersem nerelerde oynama yapmam gerektiğini sanırsam tam olarak anlayamayacağım.

Daha sadesi yok mudur acaba kolayca farklı dosyalarda uygulanabilecek, Satır-Sütun numaraları vs değişimiyle yapılabilecek bir şey.

Korhan Ayhan · 27 Mart 2021

Deneyiniz.

C++:

Option Explicit

Sub Duseyara()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long
    
    Set S1 = Sheets("Sheet3")
    Set S2 = Sheets("Sheet2")
    
    S1.Range("B2:C" & S1.Rows.Count).ClearContents
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
        
    If Son > 1 Then
        With S1
            With .Range("B2:B" & Son)
                .Formula = "=IFERROR(VLOOKUP(A2,'" & S2.Name & "'!A:C,2,0),"""")"
                .Value = .Value
            End With
            
            With .Range("C2:C" & Son)
                .Formula = "=IFERROR(VLOOKUP(A2,'" & S2.Name & "'!A:C,3,0),"""")"
                .Value = .Value
            End With
        End With

        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    End If
End Sub

cedi007 · 28 Mart 2021

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Sub Duseyara()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long
   
    Set S1 = Sheets("Sheet3")
    Set S2 = Sheets("Sheet2")
   
    S1.Range("B2:C" & S1.Rows.Count).ClearContents
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
       
    If Son > 1 Then
        With S1
            With .Range("B2:B" & Son)
                .Formula = "=IFERROR(VLOOKUP(A2,'" & S2.Name & "'!A:C,2,0),"""")"
                .Value = .Value
            End With
           
            With .Range("C2:C" & Son)
                .Formula = "=IFERROR(VLOOKUP(A2,'" & S2.Name & "'!A:C,3,0),"""")"
                .Value = .Value
            End With
        End With

        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    End If
End Sub

Üstadım ellerinize emeğinize sağlık, şimdi kendi diğer dosyalarıma uyarlayabiliyorum. Teşekkürler.

cedi007 · 31 Mart 2021

Tekrardan Selamlar,

Konuyla bağlantısı olduğundan yine buradan devam etmek istedim.
Ek'te Ornek adında bir Excell dosyam mevcut. Bu dosya'da şu işlemleri makro ile yaptırmak istiyorum.

-Sheet1 sayfasındaki G sütununu referans alıp, Sheet3 sayfasındaki G:R ile karşılaştırarak, Sheet1 'deki S sütunundaki sadece "Boş Olan" satırlara getirtmek istiyorum. Özetle bir VLOOKUP işlemi olmuş olacak. Takıldığım nokta; Eğer Sheet1'deki S sütunu boşsa değeri yaz, doluysa değiştirme işlemi.

Umarım anlatabilmişimdir. Değerli bilgi ve tecrübelerinize sunuyorum.

Korhan Ayhan · 31 Mart 2021

Bu tarz işlemler için döngü kullanmak daha avantajlıdır.

C++:

Option Explicit

Sub Duseyara()
    Dim S1 As Worksheet, S2 As Worksheet, Aranan As Variant
    Dim Son As Long, Alan As Range, Veri As Range, Bul As Variant
  
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet3")
  
    Son = S1.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  
    If Son > 1 Then
        On Error Resume Next
        Set Alan = Nothing
        Set Alan = S1.Range("S2:S" & Son).SpecialCells(xlCellTypeBlanks)
        On Error GoTo 0
        If Not Alan Is Nothing Then
            For Each Veri In Alan
                Aranan = S1.Cells(Veri.Row, "G").Value
                On Error Resume Next
                Bul = Empty
                Bul = WorksheetFunction.VLookup(Aranan, S2.Range("G:R"), 12, 0)
                On Error GoTo 0
                If Bul <> Empty Then Veri.Value = Bul
            Next
          
            MsgBox "İşleminiz tamamlanmıştır.", vbInformation
        Else
            MsgBox "Boş hücre bulunamadı!", vbExclamation
        End If
    End If

    Set Alan = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

cedi007 · 1 Nisan 2021

Merhaba,

Dönüşünüz için teşekkürler @Korhan Ayhan bey.
Belirtmiş olduğunuz makroyu uyguladığımda, boş olan hücrelere değer getirmiyor malesef.

Sanırım ben talebimi eksik aktardım. Tekrar detaylı ifade etmek isterim;

-Sheet1'deki önceden birleştirilmiş(E2:F2..vlookup için yapıyorum tabi) olan G sütununu, Sheet3'deki önceden birleştirilmiş(E2:F2..vlookup için yapıyorum tabi) G2:R2;12:0 'daki verileri, Sheet1'de S sütununda sadece boş olan hücrelere yazdırmak istiyorum.

cedi007 · 1 Nisan 2021

cedi007' Alıntı:
Merhaba,

Dönüşünüz için teşekkürler @Korhan Ayhan bey.
Belirtmiş olduğunuz makroyu uyguladığımda, boş olan hücrelere değer getirmiyor malesef.

Sanırım ben talebimi eksik aktardım. Tekrar detaylı ifade etmek isterim;

-Sheet1'deki önceden birleştirilmiş(E2:F2..vlookup için yapıyorum tabi) olan G sütununu, Sheet3'deki önceden birleştirilmiş(E2:F2..vlookup için yapıyorum tabi) G2:R2;12:0 'daki verileri, Sheet1'de S sütununda sadece boş olan hücrelere yazdırmak istiyorum.

Algoritmayı yanlış kurduğumu farkettim. O yüzden tekrar yazma gereği duydum.

-Sheet1'deki F sütununu, Sheet2'deki A:E 5;0 ile karşılaştırıp, Sheet1 S sütunundaki sadece hücrelere yazdırsın.

Korhan Ayhan · 1 Nisan 2021

Deneyiniz.

C++:

Option Explicit

Sub Duseyara()
    Dim S1 As Worksheet, S2 As Worksheet, Aranan As Variant
    Dim Son As Long, Alan As Range, Veri As Range, Bul As Variant
  
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
  
    Son = S1.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  
    If Son > 1 Then
        On Error Resume Next
        Set Alan = Nothing
        Set Alan = S1.Range("S2:S" & Son).SpecialCells(xlCellTypeBlanks)
        On Error GoTo 0
        If Not Alan Is Nothing Then
            For Each Veri In Alan
                Aranan = S1.Cells(Veri.Row, "F").Value
                On Error Resume Next
                Bul = Empty
                Bul = WorksheetFunction.VLookup(Aranan, S2.Range("A:E"), 5, 0)
                On Error GoTo 0
                If Bul <> Empty Then Veri.Value = Bul
            Next
          
            MsgBox "İşleminiz tamamlanmıştır.", vbInformation
        Else
            MsgBox "Boş hücre bulunamadı!", vbExclamation
        End If
    End If

    Set Alan = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

cedi007 · 1 Nisan 2021

Korhan bey tekrar selamlar,

Excell dosyasında açıklamalarını belirttiğim eksiklikler mevcut. İnceleyebilir misiniz mümkünse.

Örneğin;
-Değer getirmesi gereken bazı boş hücrelere değer yazmamış
-Değer yazdırdığını da hepsinde aynı değeri yazdırmış.

A: değeri "Sabit Değer1" iken A'yı buldurduğu yerde "Sabit Değer4" yazdırmış gibi.

Umarım aktarabilmişimdir. Teşekkürler.

Korhan Ayhan · 1 Nisan 2021

Sizin sorgulamak istediğiniz alan "R" sütunu ama kodlarda "S" sütunu tanımlı..

Ek olarak döngü içinde Veri yazmam gerekirken sehven Alan azdığım için sonuçlar hatalı olmuş. #14 ve #17 nolu mesajlarım da ki kodları revize ettim.

Son hallerini deneyiniz.

cedi007 · 1 Nisan 2021

Korhan Ayhan' Alıntı:
Sizin sorgulamak istediğiniz alan "R" sütunu ama kodlarda "S" sütunu tanımlı..

Ek olarak döngü içinde Veri yazmam gerekirken sehven Alan azdığım için sonuçlar hatalı olmuş. #14 ve #17 nolu mesajlarım da ki kodları revize ettim.

Son hallerini deneyiniz.

Haklısınız, çünkü yanlış dosyayı ek'e koymuşum. Şimdi tekrar Upload ettim.

Makro ile şartlı veri yazdırma

cedi007

Tevfik_Kursun

cedi007

Tevfik_Kursun

cedi007

Ekli dosyalar

Korhan Ayhan

Administrator

cedi007

cedi007

Ekli dosyalar

Korhan Ayhan

Administrator

cedi007

Korhan Ayhan

Administrator

cedi007

cedi007

Ekli dosyalar

Korhan Ayhan

Administrator

cedi007

Ekli dosyalar

cedi007

Ekli dosyalar

Korhan Ayhan

Administrator

cedi007

Ekli dosyalar

Korhan Ayhan

Administrator

cedi007

Ekli dosyalar