• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Makro ile şartlı veri yazdırma

C

cedi007

Katılım
4 Nisan 2018
Mesajlar
68
Excel Vers. ve Dili
Office 365 - İngilizce
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 bey, emeğinize sağlık çok başarılı.
 
Rica ederim, dönüş yaptığınız için ben teşekkür ederim.
İyi çalışmalar
 
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 :)
 

Ekli dosyalar

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
 
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
Genişletmek için tıkla ...

Muhteşem :) )) Teşekkürler Korhan bey.
 
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.
 

Ekli dosyalar

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
 
@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.
 
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
 
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
Genişletmek için tıkla ...

Üstadım ellerinize emeğinize sağlık, şimdi kendi diğer dosyalarıma uyarlayabiliyorum. Teşekkürler.
 
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.
 

Ekli dosyalar

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
 
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.
 

Ekli dosyalar

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.
Genişletmek için tıkla ...

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.
 

Ekli dosyalar

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
 
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.
 

Ekli dosyalar

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.
 
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.
Genişletmek için tıkla ...

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

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst