Macro ile Bul yan satırına belirtilen açıklamayı yaz

Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
Merhabalar,
A sütunda 400 adet isim var. Bul değiştir ile ismin yan satırına cümle yazdırmak istiyorum tek isim için aşağıda belirttiğim kod ile yapabiliyorum. 400 adet için bunu nasıl yapabilirim. Ben bu macroyu tırnak işareti içindeki isimleri değiştirerek alt alta kopyaladım hata verdi yardımcı olabilecek var mı?



Sub SearchText()

Dim SearchString, SearchChar, MyPos
SearchChar = "YBTAS"
For Each cell In Range("A1:A1000")
SearchString = cell.Text
MyPos = InStr(SearchString, SearchChar)
If MyPos > 0 Then
cell(1, 2).Value = "ANA PAZAR"
End If
Next
End Sub
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,323
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Örnek dosya paylaşarak talebinizi açıklar mısınız?

Dosya paylaşım sitelerine örnek dosyanızı yükleyip linkini paylaşabilirsiniz.
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,323
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Ne yapmak istiyorsunuz?
 
Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
Ne yapmak istiyorsunuz?
Az önce üstte verdiğim macro ile YBTAS yan satırına ANA PAZAR yazdırmıştım. Bunu diğerleri içinde yapmak için istiyorum.

Macroyu bu şekilde çoğaltarak gidebilirmiyim diye düşündüm denedim hata verdi

Sub SearchText()

Dim SearchString, SearchChar, MyPos
SearchChar = "YBTAS"
For Each cell In Range("A1:A1000")
SearchString = cell.Text
MyPos = InStr(SearchString, SearchChar)
If MyPos > 0 Then
cell(1, 2).Value = "ANA PAZAR"
End If
Next

Dim SearchString, SearchChar, MyPos
SearchChar = "PKENT"
For Each cell In Range("A1:A1000")
SearchString = cell.Text
MyPos = InStr(SearchString, SearchChar)
If MyPos > 0 Then
cell(1, 2).Value = "YILDIZ PAZAR"
End If
Next
End Sub
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,323
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
PKENT için YILDIZ PAZAR demişsiniz. Bu verilerin tam listesi varsa döngü ile kolaylıkla yapılabilir. Hatta formülle de çözüm uygulanabilir.
 
Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
PKENT için YILDIZ PAZAR demişsiniz. Bu verilerin tam listesi varsa döngü ile kolaylıkla yapılabilir. Hatta formülle de çözüm uygulanabilir.
Ben düşey ara ile yapabiliyorum ancak pc de ek bir dosya olması gerekiyor. Bu nedenle macro içerisinde dolsa çok daha iyi olacak. Tüm veriler ekli dosyadadır. Zaman içerisinde eksiltme ilaveler oluyor. Macro içerisinden değiştirerek ilerleyebileceğimi düşünüyorum.

 
Son düzenleme:

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,323
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Bu dosyadaki sayfayı diğer dosyanızın içine kopyalayın.

Sonrasında makro ile veriler kolaylıkla değiştirilebilir.

Şuan dışarıdayım cevap veren olmazsa eve geçince yanıtlarım.
 

muratboz06

Destek Ekibi
Destek Ekibi
Katılım
23 Mart 2017
Mesajlar
552
Excel Vers. ve Dili
Office365 TR
Linkteki çalışma işinizi görecektir.
Pazarlar listesini ikinci sayfaya ekledim.
 
Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
Bu dosyadaki sayfayı diğer dosyanızın içine kopyalayın.

Sonrasında makro ile veriler kolaylıkla değiştirilebilir.

Şuan dışarıdayım cevap veren olmazsa eve geçince yanıtlarım.
Korhan Bey,
Size örnek olarak attığım turkey_2020-10-28.xlsx dosyası internet sitesinden her gün cvs olarak indirilen bir dosyadır. Ve farklı bir macro ile düzenlenen bir dosyadır. Sabit bir dosya olsa dediğiniz gibi yapacaktım. Hatta şu an düşeyara ile öyle kullanıyorum. Benim amacım dosyayı indirir indirmez tek macro ile hazır hale getirmekti
 
Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
Korhan Bey,
Size örnek olarak attığım turkey_2020-10-28.xlsx dosyası internet sitesinden her gün cvs olarak indirilen bir dosyadır. Ve farklı bir macro ile düzenlenen bir dosyadır. Sabit bir dosya olsa dediğiniz gibi yapacaktım. Hatta şu an düşeyara ile öyle kullanıyorum. Benim amacım dosyayı indirir indirmez tek macro ile hazır hale getirmekti
Korhan Bey,
İlk verdiğim macro tırnak içerisinde yazdığım isim için değişiklik yapıyor. O macroya döngü yapılabilir mi? yapılır ise ben her isim için ayrı ayrı isimleri değiştirerek VBA tarafına giriş yapabilirim.
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,323
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
O zaman şöyle yapabiliriz.

Son paylaştığınız dosyaya makroyu yazarız. Bu makroyu çalıştırdığınızda sizden güncellemek istediğiniz dosyayı seçmenizi ister. Yapacağınız dosya seçimine göre ilgili veriler seçtiğiniz dosyaya aktarılır ve kaydedilir.

Bu senaryo sizin için uygun mu?
 
Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
O zaman şöyle yapabiliriz.

Son paylaştığınız dosyaya makroyu yazarız. Bu makroyu çalıştırdığınızda sizden güncellemek istediğiniz dosyayı seçmenizi ister. Yapacağınız dosya seçimine göre ilgili veriler seçtiğiniz dosyaya aktarılır ve kaydedilir.

Bu senaryo sizin için uygun mu?
Sizin için çok yorucu olmayacak ise olur.
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,323
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Aşağıdaki kodu son eklediğiniz dosyaya uygulayıp çalıştırın.

Sizden dosya seçmenizi isteyecek. Dosya seçiminden sonra arama yapılacak ve eşleşen kayıtlar seçtiğiniz dosyaya B sütununa aktarılacaktır.

C++:
Option Explicit

Sub Verileri_Aktar()
    Dim XL_App As Object, Dosya As Object, S1 As Worksheet, S2 As Object
    Dim Veri As Range, Bul As Range, Adres As String, Son As Long, Say As Long
    
    Set S1 = ThisWorkbook.Sheets("Sayfa1")
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    
    With Application.FileDialog(msoFileDialogOpen)
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xl*", 1
        .FilterIndex = 1
        .InitialFileName = ThisWorkbook.Path
        .Show
        
        If .SelectedItems.Count = 0 Then
            MsgBox "İşleme devam edebilmeniz için dosya seçimi yapmalısınız!", vbCritical
            Exit Sub
        End If
        
        Set XL_App = CreateObject("Excel.Application")
        XL_App.Visible = False
        
        Set Dosya = XL_App.Workbooks.Open(.SelectedItems(1))
        Set S2 = Dosya.Sheets(1)
        
        For Each Veri In S1.Range("A1:A" & Son)
            If Veri.Value <> "" Then
                Set Bul = S2.Range("A:A").Find(Veri.Value, , , xlWhole)
                If Not Bul Is Nothing Then
                    Adres = Bul.Address
                    Do
                        S2.Cells(Bul.Row, 2) = Veri.Offset(, 1).Value
                        Say = Say + 1
                        Set Bul = S2.Range("A:A").FindNext(Bul)
                    Loop While Not Bul Is Nothing And Bul.Address <> Adres
                End If
            End If
        Next
    End With

    Dosya.Save
    Dosya.Close False
    XL_App.Quit
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dosya = Nothing
    Set XL_App = Nothing

    MsgBox Say & " adet veri aktarılmıştır.", vbInformation
End Sub
 
Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
Aşağıdaki kodu son eklediğiniz dosyaya uygulayıp çalıştırın.

Sizden dosya seçmenizi isteyecek. Dosya seçiminden sonra arama yapılacak ve eşleşen kayıtlar seçtiğiniz dosyaya B sütununa aktarılacaktır.

C++:
Option Explicit

Sub Verileri_Aktar()
    Dim XL_App As Object, Dosya As Object, S1 As Worksheet, S2 As Object
    Dim Veri As Range, Bul As Range, Adres As String, Son As Long, Say As Long
   
    Set S1 = ThisWorkbook.Sheets("Sayfa1")
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
   
    With Application.FileDialog(msoFileDialogOpen)
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xl*", 1
        .FilterIndex = 1
        .InitialFileName = ThisWorkbook.Path
        .Show
       
        If .SelectedItems.Count = 0 Then
            MsgBox "İşleme devam edebilmeniz için dosya seçimi yapmalısınız!", vbCritical
            Exit Sub
        End If
       
        Set XL_App = CreateObject("Excel.Application")
        XL_App.Visible = False
       
        Set Dosya = XL_App.Workbooks.Open(.SelectedItems(1))
        Set S2 = Dosya.Sheets(1)
       
        For Each Veri In S1.Range("A1:A" & Son)
            If Veri.Value <> "" Then
                Set Bul = S2.Range("A:A").Find(Veri.Value, , , xlWhole)
                If Not Bul Is Nothing Then
                    Adres = Bul.Address
                    Do
                        S2.Cells(Bul.Row, 2) = Veri.Offset(, 1).Value
                        Say = Say + 1
                        Set Bul = S2.Range("A:A").FindNext(Bul)
                    Loop While Not Bul Is Nothing And Bul.Address <> Adres
                End If
            End If
        Next
    End With

    Dosya.Save
    Dosya.Close False
    XL_App.Quit
   
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dosya = Nothing
    Set XL_App = Nothing

    MsgBox Say & " adet veri aktarılmıştır.", vbInformation
End Sub
Çok teşekkür ederim zahmet verdim 🙏🙏🙏
 
Üst