Koşula bağlı veri aktarımı

[karakayalı]

dusyam EK'tedir....yardımlarınız için şimdiden teşekkürler

 

[ÖmerFaruk]

Sarı hücrelerdeki il isimleri de Sayfa 2 den mi alınacak?

 

[karakayalı]

evet ömer faruk bey

 

[karakayalı]

Gün boyunca uğraştım ancak başaramadım. Yardımlarınızı bekliyorum.

 

[ÖmerFaruk]

Aşağıdaki kodları boş bir modüle ekleyip çalıştırabilirsiniz.

Sub Aktar()
    Dim Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet
    Dim dizi, Liste, Dict1 As Object, Dict2 As Object, Alan As Range
    Dim Satır As Integer, Sütun As Integer, Ofset As Integer, i As Integer, Say As Integer, Son As Integer
    Set Dict1 = CreateObject("Scripting.Dictionary")
    Set Dict2 = CreateObject("Scripting.Dictionary")
    Set Sh1 = Worksheets("Sayfa1")
    Set Sh2 = Worksheets("Sayfa2")
    Set Sh3 = Worksheets("Sayfa3")
    Sh1.Range("A4:G" & Rows.Count).Clear
    Son = Sh2.Range("A" & Rows.Count).End(3).Row
    If Son > 1 Then
        dizi = Sh2.Range("A2").Resize(Sh2.Range("A2").End(xlDown).Row - 1, 2).Value
    Else
        MsgBox "Var olan şehir listeniz boş": GoTo SonaAtla
    End If
    Son = Sh3.Range("A1").CurrentRegion.Rows.Count
    If Son > 1 Then
        Set Alan = Sh3.Range("A2:J" & Son)
    Else
        MsgBox "Var olan isim listeniz boş": GoTo SonaAtla
    End If
    ReDim Liste(1 To Rows.Count, 1 To 7)
    For i = 1 To UBound(dizi)
        If WorksheetFunction.CountIf(Alan, dizi(i, 2)) > 0 Then
            If Not Dict1.Exists(dizi(i, 1)) Then
                Say = Say + 1
                Dict1.Add dizi(i, 1), Say
                Dict2.Add Say, 1
            Else
                Dict2(Say) = Dict2(Say) + 1
            End If
            Satır = WorksheetFunction.RoundDown((Dict1(dizi(i, 1)) - 1) / 7, 0)
            Satır = Satır * 12 + 1
            Ofset = Dict2(Dict1(dizi(i, 1)))
            Sütun = Dict1(dizi(i, 1)) Mod 7
            If Sütun = 0 Then Sütun = 7
            Liste(Satır, Sütun) = dizi(i, 1)
            Liste(Satır + Ofset, Sütun) = dizi(i, 2)
        End If
    Next i
    If Say > 0 Then
        Satır = WorksheetFunction.RoundUp((Dict1.Count) / 7, 0) * 12
        Sh1.Range("A4").Resize(Satır, 7) = Liste
        For i = 0 To WorksheetFunction.RoundUp((Dict1.Count) / 7, 0) - 1
            With Sh1.Range("A4").Offset(i * 12, 0).Resize(1, 7)
                .Interior.Color = vbYellow
                .Font.Color = vbRed
                
            End With
        Next i
        MsgBox "İşlem tamamlandı"
    Else
        MsgBox "Uygun isim bulunamadı"
    End If
SonaAtla:
    Set Sh1 = Nothing: Set Sh2 = Nothing: Set Sh3 = Nothing
    Set Dict1 = Nothing: Set Dict2 = Nothing: Set Alan = Nothing: Erase dizi: Erase Liste
End Sub

 

[karakayalı]

ömer faruk bey...öncelikle yazdığınız kodu kullanmaktayım ve çokta istifade etmekteyim...yalnız AKTAR dediğimde sayfa1 de bulunan verilerin tamamı siliniyor...Bunun 30 uncu satırdan sonra silinmemesini istiyorum...Birde başlık kısımlarının sabit olmasını yani başlık kısımlarının yerini değiştirdiğimde veriler o başlık altına gelmesini sağlayabilirmiyiz...Yardımcı olacak arkadaşlara emekleri için şimdiden teşekkürler

 

[ÖmerFaruk]

"AKTAR dediğimde sayfa1 de bulunan verilerin tamamı siliniyor...Bunun 30 uncu satırdan sonra silinmemesini istiyorum"

Sh1.Range("A4:G" & Rows.Count).Clear
'yerine aşağıdkai satırı kullanın
Sh1.Range("A30:G" & Rows.Count).Clear

İkinci sorunuzu ise anlamadım.
Zira başlık dediğiniz sanırım il isimleri. Ve benim yazdığım kodlarda hangi iller varsa onları başlaık satır(lar)ı olarak sıralıyorum.
İlk sorunuzda böyle bir ifadeniz olmadığı için #2 nolu mesajımda özellikle sormuştum Sarı hücrelerdeki il isimleri de Sayfa 2 den mi alınacak?
Cevabınız evet olmuştu.

Şimdi isteğinizi bir kez daha gözden geçirip bizim de anlayacağımız şekilde sorarsanız kolaylıla cevap verebilirim.

 

[karakayalı]

teşekkürlerr ömer faruk bey...diğer kısmı hallettim...