Koşula Dayalı Süzme"Makro Yazma"

[erseljti]

Merhabalar
Öncelikle Excel dosyam office 2010 formatında bunu belirtmek isterim.2010 yüklü olmayan üstadlar 2003 olarakta mantığını anlatırsa ben devamını getirebileceğim kanaatindeyim.
Excel çalışmam VSEÇ formülüyle entegre edilmiş.Bu çalışmamda 3 Sheet mevcut.
Menü-Data-Bayi Listesi Sheetleri.
İstediğim şudur:
Menü shhetinde Data sheetindeki bilgilere göre koşula uyan sayısal veriyi alıyoruz.Amacımız Bu aldığımız sayısal veriyi mesala 8 sayısının koşula uyan bayi Listesini Bayi Listesi Sheetine Makro ile aktarmak.Yani koşula dayalı Süzme yapmamız gerekmektedir.Ek te daha detaylı açıklamam mevcut.
İlgi ve alakalnızı rica ederim.Lütfen Makrodan anlayan Sevgili Üstadlar ilgilenirse çok sevinirim.
Teşekkürler.
Eki Revize ederek 4.mesja koydum

 

[erseljti]

Sevgili Üstadlar sorunuma ilgilerinizi rica ederim.

 

[asi_kral]

Merhaba
H Sütununda bulunan Kanal'ı hangi sütunda arayacak. Onu bulamadım.

 

[asi_kral]

Bayi Listesi sekmesinde aynı verilerden 2 şer tane olanlar var onlar ne olacak

 

[erseljti]

Bayi Listesi sekmesinde aynı verilerden 2 şer tane olanlar var onlar ne olacak

Üstad Kanal Sutununu ekledim.
Revize dosya Ektedir

 

[asi_kral]

Üstad Kanal Sutununu ekledim.
Revize dosya Ektedir

Merhaba
Boş bir module kopyalayın ve deneyin.

Option Explicit
Sub Verileri_Süz_Aktar_1967()
'Konu       :   Yazılan Bilgileri Süz Adet Bul ve Kapyala
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Coder By   :   asi_kral_1967
Dim asi As Worksheet, kral As Worksheet, excel As Worksheet
Dim a As Long, b As Long, c As Long, aa As String, ab As String
Set asi = Sheets("Menü"): Set kral = Sheets("Data")
Set excel = Sheets("Bayi Listesi")
Application.ScreenUpdating = False
aa = ActiveSheet.Name: excel.Select: ab = ActiveCell.Address
excel.Range("A2:AN" & Rows.Count).ClearContents
b = kral.Range("A" & Rows.Count).End(xlUp).Row
For a = 1 To 10
If asi.Cells(2, a) <> Empty Then
c = WorksheetFunction.Match(asi.Cells(1, a), kral.Range("A2:APA2"), 0)
kral.Range("A2:APA" & b).AutoFilter field:=c, Criteria1:=asi.Cells(2, a)
End If: Next
asi.Range("K2") = WorksheetFunction.Subtotal(3, kral.Range("A3:A" & b))
If asi.Range("K2") > 0 Then
kral.Range("A3:F" & b).Copy: excel.Range("A2").PasteSpecial (xlPasteValues)
kral.Range("K3:M" & b).Copy: excel.Range("G2").PasteSpecial (xlPasteValues)
kral.Range("O3:O" & b).Copy: excel.Range("J2").PasteSpecial (xlPasteValues)
kral.Range("BH3:BH" & b).Copy: excel.Range("K2").PasteSpecial (xlPasteValues)
kral.Range("DA3:DA" & b).Copy: excel.Range("L2").PasteSpecial (xlPasteValues)
kral.Range("ET3:ET" & b).Copy: excel.Range("M2").PasteSpecial (xlPasteValues)
kral.Range("GM3:GM" & b).Copy: excel.Range("N2").PasteSpecial (xlPasteValues)
kral.Range("IF3:IF" & b).Copy: excel.Range("O2").PasteSpecial (xlPasteValues)
kral.Range("JY3:JY" & b).Copy: excel.Range("P2").PasteSpecial (xlPasteValues)
kral.Range("LR3:LR" & b).Copy: excel.Range("Q2").PasteSpecial (xlPasteValues)
kral.Range("NK3:NK" & b).Copy: excel.Range("R2").PasteSpecial (xlPasteValues)
kral.Range("PD3:PD" & b).Copy: excel.Range("S2").PasteSpecial (xlPasteValues)
kral.Range("QW3:QW" & b).Copy: excel.Range("T2").PasteSpecial (xlPasteValues)
kral.Range("SP3:SP" & b).Copy: excel.Range("U2").PasteSpecial (xlPasteValues)
kral.Range("UI3:UI" & b).Copy: excel.Range("V2").PasteSpecial (xlPasteValues)
kral.Range("WB3:WB" & b).Copy: excel.Range("W2").PasteSpecial (xlPasteValues)
kral.Range("XU3:XU" & b).Copy: excel.Range("X2").PasteSpecial (xlPasteValues)
kral.Range("ZN3:ZN" & b).Copy: excel.Range("Y2").PasteSpecial (xlPasteValues)
kral.Range("ABG3:ABG" & b).Copy: excel.Range("Z2").PasteSpecial (xlPasteValues)
kral.Range("ACZ3:ACZ" & b).Copy: excel.Range("AA2").PasteSpecial (xlPasteValues)
kral.Range("AES3:AES" & b).Copy: excel.Range("AB2").PasteSpecial (xlPasteValues)
kral.Range("AGL3:AGL" & b).Copy: excel.Range("AC2").PasteSpecial (xlPasteValues)
kral.Range("AIE3:AIE" & b).Copy: excel.Range("AD2").PasteSpecial (xlPasteValues)
kral.Range("AJX3:AJX" & b).Copy: excel.Range("AE2").PasteSpecial (xlPasteValues)
kral.Range("ALQ3:ALQ" & b).Copy: excel.Range("AF2").PasteSpecial (xlPasteValues)
kral.Range("ANJ3:ANJ" & b).Copy: excel.Range("AG2").PasteSpecial (xlPasteValues)
kral.Range("A2:APA" & b).AutoFilter
End If
excel.Range(ab).Select: Sheets(aa).Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, "asi_kral_1967"
End Sub

Dosyanız Ekte.