Makro ile iki sheet arasındaki değerleri getirme

[YakupErgül]

Merhaba Arkadaşlar ,

aynı excelde iki adet sheet bulunuyor.Bu sheet1 deki Bölge kolonunu sheet2 altında Bölge kolonu açıp yanına yazdırmak istiyorum.

Bunu nasıl makro ile yapabilirim.

sheet1 ve sheet2

sheet1 altında ;
BHM:aaa,bbb,ccc ve Bölge : İç Anadolu, İstanbul,Ankara

sheet2 altında;
BHM :aaa,bbb,ccc

 

[YUSUF44]

DÜŞEYARA formülünü denediniz mi?

Makro istemenizin başka özel bir sebebi mi var?

 

[YakupErgül]

DÜŞEYARA formülünü denediniz mi?

Makro istemenizin başka özel bir sebebi mi var?

Denedim fakat olmadı.
Vlookup yapamayan birilerine gönderiyorum

 

[YUSUF44]

Örnek bir dosya paylaşır mısınız?

 

[YakupErgül]

Örnek bir dosya paylaşır mısınız?

Dosya paylasamadigim için burada anlatmak istedim.

 

[YakupErgül]

Dosya paylasamadigim için burada anlatmak istedim.

Nerden Dosya paylaşımı yapabilirim.en son yapmak istediğimde üyelik istemişti

 

[izcik]

Nerden Dosya paylaşımı yapabilirim.en son yapmak istediğimde üyelik istemişti

Dosya.tc
dosya.co

 

[YakupErgül]

Dosya.tc
dosya.co

mail adresinizi paylaşabilirmisiniz.tşk ederim.

 

[YakupErgül]

mail adresinizi paylaşabilirmisiniz.tşk ederim.

İndir Vlookup

Dosyayı indir Vlookup

dosya.co

gerekli yüklemeyi yaptım.Sheet1 deki BHM ismine göre SME Fiber&RL Devam Eden sheetinde Bölgesini yazıyor olacak.

Son satırara kadar.

 

[YakupErgül]

İndir Vlookup

Dosyayı indir Vlookup

dosya.co

gerekli yüklemeyi yaptım.Sheet1 deki BHM ismine göre SME Fiber&RL Devam Eden sheetinde Bölgesini yazıyor olacak.

Son satırara kadar.

Kontrol edebildiniz mi?
Tsk ederim

 

[Korhan Ayhan]

Merhaba,

SME Fiberli&RL Devam Eden sayfasında B2 hücresine uygulayıp alt hücrelere sürüleyiniz.

=VLOOKUP(A2;Sheet1!A:B;2;0)

 

[YakupErgül]

Merhaba,

SME Fiberli&RL Devam Eden sayfasında B2 hücresine uygulayıp alt hücrelere sürüleyiniz.

=VLOOKUP(A2;Sheet1!A:B;2;0)

Macro kodu ile yapılması gerekiyor.yardimci olabilirmisiniz.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Bolge_Bul()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object, Say As Long
    Dim Veri As Variant, Son As Long, X As Long, Zaman As Double

    Application.ScreenUpdating = False

    Zaman = Timer

    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("SME Fiber&RL Devam Eden")
    Set Dizi = CreateObject("Scripting.Dictionary")

    S2.Range("B2:B" & S2.Rows.Count).Clear

    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A2:B" & Son).Value

    For X = LBound(Veri) To UBound(Veri)
        Dizi.Item(Veri(X, 1)) = Veri(X, 2)
    Next

    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
    Veri = S2.Range("A2:A" & Son).Value

    ReDim Liste(1 To Son, 1 To 1)
    
    For X = LBound(Veri) To UBound(Veri)
        If Dizi.Exists(Veri(X, 1)) Then
            Liste(X, 1) = Dizi.Item(Veri(X, 1))
        Else
            Liste(X, 1) = "Bulunamadı!"
        End If
    Next

    S2.Range("B2").Resize(Son) = Liste
    S2.Columns.AutoFit

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing

    Application.ScreenUpdating = True

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

 

[YakupErgül]

Sub Bolge_Bul() Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object, Say As Long Dim Veri As Variant, Son As Long, X As Long, Zaman As Double Application.ScreenUpdating = False Zaman = Timer Set S1 = Sheets("Sheet1") Set S2 = Sheets("SME Fiber&RL Devam Eden") Set Dizi = CreateObject("Scripting.Dictionary") S2.Range("B2:B" & S2.Rows.Count).Clear Son = S1.Cells(S1.Rows.Count, 1).End(3).Row Veri = S1.Range("A2:B" & Son).Value For X = LBound(Veri) To UBound(Veri) Dizi.Item(Veri(X, 1)) = Veri(X, 2) Next Son = S2.Cells(S2.Rows.Count, 1).End(3).Row Veri = S2.Range("A2:A" & Son).Value ReDim Liste(1 To Son, 1 To 1) For X = LBound(Veri) To UBound(Veri) If Dizi.Exists(Veri(X, 1)) Then Liste(X, 1) = Dizi.Item(Veri(X, 1)) Else Liste(X, 1) = "Bulunamadı!" End If Next S2.Range("B2").Resize(Son) = Liste S2.Columns.AutoFit Set S1 = Nothing Set S2 = Nothing Set Dizi = Nothing Application.ScreenUpdating = True MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _ "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation End Sub

tşk ederim.