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

M

muratot

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

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,738
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

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,738
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Ne yapmak istiyorsunuz?
 
M

muratot

Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
Korhan Ayhan' Alıntı:
Ne yapmak istiyorsunuz?
Genişletmek için tıkla ...
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

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,738
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.
 
M

muratot

Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
Korhan Ayhan' Alıntı:
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.
Genişletmek için tıkla ...
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.

İndir XU100

Dosyayı indir XU100
dosya.co
 
Son düzenleme:
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,738
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.
 
M

muratboz06

Destek Ekibi
Destek Ekibi
Katılım
23 Mart 2017
Mesajlar
568
Excel Vers. ve Dili
Office365 TR
Linkteki çalışma işinizi görecektir.
Pazarlar listesini ikinci sayfaya ekledim.

İndir turkey 2020

Dosyayı indir turkey 2020
dosya.co
 
M

muratot

Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
Korhan Ayhan' Alıntı:
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.
Genişletmek için tıkla ...
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
 
M

muratot

Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
muratot' Alıntı:
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
Genişletmek için tıkla ...
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

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,738
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?
 
M

muratot

Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
Korhan Ayhan' Alıntı:
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?
Genişletmek için tıkla ...
Sizin için çok yorucu olmayacak ise olur.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,738
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
 
M

muratot

Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
Korhan Ayhan' Alıntı:
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
Genişletmek için tıkla ...
Çok teşekkür ederim zahmet verdim 🙏🙏🙏
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst