veri doğrulama ile düşeyara

[qwertylion]

ekteki dosyadan anlaşılacağı üzere veri doğrulama ile il seçip, düşeyara ile ilgili sayfalardan verileri alıp ilgili sütuna yazdırıyorum. ancak ben bunu makro ile yapmak istiyorum. nedeni ise asıl dosyamın 22 sütun ve 15000 satırsan oluşuyor sayfa adedi ie 14 tane haliyle buda işyerindeki eski olan bilgisayarımı iyice yavaşlatıyor.

yardımcı olursanız çok sevinirim.

 

[Korhan Ayhan]

Selamlar,

Boş bir modüle aşağıdaki kodu uygulayın.

Option Explicit
 
Sub AKTAR()
    Dim SAYFA As Worksheet, ŞEHİR As String
    Dim X As Byte, BUL As Range
    
    ŞEHİR = Range("A2")
    
    Application.ScreenUpdating = False
    
    For Each SAYFA In Worksheets
        If SAYFA.Name <> "deneme" Then
            Set BUL = SAYFA.Range("A:A").Find(ŞEHİR, LookAt:=xlWhole)
            If Not BUL Is Nothing Then
                For X = 2 To 14
                    If Cells(4, X) = SAYFA.Name Then
                    SAYFA.Range("B" & BUL.Row & ":K" & BUL.Row).Copy
                    Cells(5, X).PasteSpecial Paste:=xlPasteValues, Transpose:=True
                    Application.CutCopyMode = False
                    GoTo Devam
                    End If
                Next
            End If
        End If
Devam:
    Next
    
    Range("A2").Select
    
    Set BUL = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

"deneme " isimli sayfanızın kod bölümünüde aşağıdaki kodu uygulayın.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A2")) Is Nothing Then Exit Sub
    AKTAR
End Sub

A2 hücresinden şehir seçip deneyin.

 

[qwertylion]

valla size ne desem az vallahi. çok teşekkür ederim sorunsuz çalışıyor kod hocam