Veriyi getir makrosu

[hopeful]

Merhaba,
Ekli dosyada H3 hücresinden il seçimi yapıldıktan sonra
"VERİ GETİR" makrosuna basıldığında , solda bulunan İLLER tablosundan ilgili ilin altındaki tüm verilerin H4 hücresinden başlayarak alt alta yazılmasını makro ile sağlamanızı rica ederim.


Örn: İzmir --> P,R,S,T
Ankara --> K,L,M,N,O,P,R

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Button4_Click()

    Dim c As Range, son As Long
    
    Application.ScreenUpdating = False
    Range("H4:H" & Rows.Count).ClearContents
    
    Set c = [A3:E3].Cells.Find([H3], , xlValues, xlWhole)
    If Not c Is Nothing Then
        son = Cells(Rows.Count, c.Column).End(xlUp).Row
        Range(Cells(4, c.Column), Cells(son, c.Column)).Copy
        [H4].PasteSpecial Paste:=xlPasteValues
    End If
    
    [H3].Select
    Application.CutCopyMode = False
    
End Sub

.

 

[Ömer BARAN]

Merhaba.

-- Formül ile çözüm isterseniz aşağıdaki formülü H4 hücresine uygulayın ve il sütunlarındaki son dolu satır sayısı kadar aşağı doğru kopyalayın.
.

=[COLOR="red"]EĞER[/COLOR]([COLOR="red"]KAYDIR[/COLOR]($A$3;[COLOR="red"]SATIR()[/COLOR]-3;[COLOR="red"]KAÇINCI[/COLOR]($H$3;$A$3:$F$3;0)-1)="";"";[COLOR="red"]KAYDIR[/COLOR]($A$3;[COLOR="red"]SATIR()[/COLOR]-3;[COLOR="Red"]KAÇINCI[/COLOR]($H$3;$A$3:$F$3;0)-1))

-- Makro ile çözüm için aşağıdaki kod'u kullanabilirsiniz.
.

[B]Sub Button4_Click()[/B]
If Cells(Rows.Count, "H").End(xlUp).Row > 3 Then _
    Range(Cells(4, "H"), Cells(Cells(Rows.Count, "H").End(xlUp).Row, "H")).ClearContents
If WorksheetFunction.CountIf(Range("A3:F3"), [H3]) = 0 Then Exit Sub
sut = WorksheetFunction.Match([H3], Range("A3:F3"), 0)
sonsat = Cells(Rows.Count, sut).End(xlUp).Row
Range(Cells(4, sut), Cells(sonsat, sut)).Copy
[H4].PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
[H3].Activate
[B]End Sub[/B]

İLAVE NOT: Sayın adaşım cevap yazmış bile, benimkisi de alternatif olsun.
.

 

[hopeful]

Çok teşekkür ederim Ömer Bey'ler

Saygılarımla