İki noktadan referans alabilen makro

[imyourfate]

Tüm Arkadaşlara iyi akşamlar

söyle bir sorumuz daha mevcut; aşağıdaki makroyu kullanarak ''AB202'' den aşağı doğru devam eden verileri ''W202'' deki verileri referans alarak ''D'' sütunundaki aynı referansa listeliyorum yani ''W202'' den aşağı devam eden kodların karşılıkları 4.satırda mevcut buraya kadar sorun yok. ''AB202'' den başlayan rakamlara ''S202'' den yazılmış olan acenta isimlerini de referans aldırmam gerekiyor.

Örnek: ''AB233'' de yer alan 100 sayısı ''W233'' de yazan harflere göre listeye yerleşiyor ama ''S233'' yer alan acenta ismine görede listeye yerleşmeli

yani : L-TUR (başında STD yazan sütun) 100 şeklinde olmalı diğer rakamlarda uygun yerlerine yerleşmeli aşağıdaki makroya bir eklenti yapılabilirse çok güzel olur
diğer varyasyonlarını kendim oluşturabilirim

ekli dosya mevcuttur

Saygılarımla İyi Akşamlar

Sub mirzapaşa()
Dim MM, MSTF, Mustafa_MUTLU1
Mustafa_MUTLU1 = Sheets("SAYFA1").Range("D4")
Application.ScreenUpdating = False
Sheets("SAYFA1").Range("C665536").ClearContents
MM = 6
For MSTF = 5 To Sheets("SAYFA1").Cells(65536, "w").End(xlUp).Row
If Sheets("SAYFA1").Cells(MSTF, "w") = Mustafa_MUTLU1 Then
Sheets("SAYFA1").Cells(MM, "D") = Sheets("SAYFA1").Cells(MSTF, "AB")
MM = MM + 1
End If
Next
Application.ScreenUpdating = True
End Sub

 

[imyourfate]

Arkadaşlar şimdi aklıma geldi bu makrodaki değişken sayısını arttırırsam olacak gibi geliyor ama...

 

[imyourfate]

arkadaşlar vaktiniz varsa bir göz atabilirseniz çıkamadım ben bunu içinden

 

[Levent Menteşoğlu]

Dosyanızdaki "mirzapaşa" isimli prosedürü silin. Daha önce verdiğim "Benzersizlerlistele" prosedürünüde aşağıdaki ile değiştirin. İstediğiniz sonucu elde edeceksiniz. Yalnız dosyanızda W sütununda bulunan "ACT" isimli bir başlık tablonuzda yok. Bu veride hata verecektir. Eğer bu veri pas gecilecekse koda bir ekleme daha yapmam gerekir. Pas geçilmeyecekse bunuda tablonuza ekleyin. Ekleme sonucunda kodda bir değişikliğe gerek olmayacaktır.

Sub Benzersizlerlistele()
For a = 202 To [s65536].End(3).Row
If WorksheetFunction.CountIf(Range("s202:s" & a), Cells(a, "s")) = 1 Then
c = c + 1
Cells(c + 5, "b") = Cells(a, "s")
End If
sat = WorksheetFunction.Match(Cells(a, "s"), [b:b], 0)
sut = WorksheetFunction.Match(Cells(a, "w"), [4:4], 0)
Cells(sat, sut) = Cells(a, "ab")
Next
End Sub

Not: 2.xlsx dosyanızı açmadan verilen aktarılacağı bir yapıda kurulabilir. Bu durumda verileri sayfa üzerine kopyalamadan sadece ADO ile işlem yapılabilir.

 

[imyourfate]

Waw Hocam müthiş bişey olmuş Allah razı olsun süper yaa

Levent Bey Hayırlı günler Diliyorum Sağlıcakla Kalınız