Filtrele ve sayı değeri kadar aktar.

[irfancantr]

Herkese iyi akşamlar;

veri sayfasında 71 adet araç markası var;
her bir araç markasında yaklaşık 10 adet alt seri var;
bu serilerin altında yine yaklaşık 10 ar adet model var.

Sorunuma gelirsek;

Bu araçları sırası ile teker teker filtre yapıyorum ve filtrelenen bu aracın isminin
filtre sayısı kadar sayfa2 ye A sütununa ilk boş hücreden başlayarak o miktarda yazması.

İkinci olarak bu işlemin ardından o model araca ait 10 seriyi filtrelemeye başlıyorum. İlk işlemin aynısını bu sefer sayfa2 de B sütununda başlayarak kaç adet yazılması gerekiyorsa (aslında yazacağı sayı miktarı en üst hücrede sayı ile belirli) o kadar yazacak.

Son olarak bu seri ismi altında kalan isimleri sayfa2 C sütununa ilk boş hücreden başlayarak aktarmaya çalışacak.

Ben olmasını istediğim şekli sayfa2 ye örnek olarak göstermeye çalıştım.

Anlatım karışık olabilir ama dosyayı inceledeğinizde daha rahat anlayacağınızı düşünüyorum.

İlgilenen herkese şimdiden çok teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Umarım sorunuzu doğru anlamışımdır.

Filtre uyguladıktan sonra aşağıdaki kodları çalıştırın. Filtreden sonra ilk görünen hücre araç adı olarak baz alınmıştır.

Sub ARAÇ_KODU_AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Hücre As Range, Marka As String
    Dim Satır As Long, Adet As Integer, Son As Long
    
    Set S1 = Sheets("veri")
    Set S2 = Sheets("Sayfa2")
    
    If Not S1.AutoFilterMode Then Exit Sub
    
    Son = S1.UsedRange.Rows.Count
    
    For Each Hücre In S1.Range("B3:B" & Son).SpecialCells(xlCellTypeVisible)
        If Hücre.Row > 3 And Hücre.Value <> "" Then
            Marka = Hücre.Value
            Exit For
        End If
    Next
    
    If S2.Range("A1") = "" Then
        Satır = 1
    Else
        Satır = S2.Cells(Rows.Count, 1).End(3).Row + 1
    End If
    
    Adet = S1.Range("E2")
    
    S2.Range("A" & Satır & ":A" & Satır + Adet - 1).Value = Marka
    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "Veriler aktarılmıştır.", vbInformation
End Sub
 
Sub SERİ_KODU_AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Hücre As Range, Satır As Long, Son As Long
    
    Set S1 = Sheets("veri")
    Set S2 = Sheets("Sayfa2")
    
    If Not S1.AutoFilterMode Then Exit Sub
    
    If S2.Range("B1") = "" Then
        Satır = 1
    Else
        Satır = S2.Cells(Rows.Count, 2).End(3).Row + 1
    End If
    
    Son = S1.UsedRange.Rows.Count
    
    For Each Hücre In S1.Range("B3:B" & Son).SpecialCells(xlCellTypeVisible)
        If Hücre.Row > 3 And Hücre.Value <> "" Then
            S2.Cells(Satır, 2) = Hücre.Value
            Satır = Satır + 1
        End If
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "Veriler aktarılmıştır.", vbInformation
End Sub
 
Sub MODEL_KODU_AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Hücre As Range, Satır As Long, Son As Long
    
    Set S1 = Sheets("veri")
    Set S2 = Sheets("Sayfa2")
    
    If Not S1.AutoFilterMode Then Exit Sub
    
    If S2.Range("C1") = "" Then
        Satır = 1
    Else
        Satır = S2.Cells(Rows.Count, 3).End(3).Row + 1
    End If
    
    Son = S1.UsedRange.Rows.Count
    
    For Each Hücre In S1.Range("B3:B" & Son).SpecialCells(xlCellTypeVisible)
        If Hücre.Row > 3 And Hücre.Value <> "" Then
            S2.Cells(Satır, 3) = Hücre.Value
            Satır = Satır + 1
        End If
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "Veriler aktarılmıştır.", vbInformation
End Sub

 

[mancubus]

ekte xlsm ve xls olarak ekledim.

acura'daki format alfaromeo ile aynı değil gibi geldi yalnız...