Makro ile verileri diğer sayfaya aktarmak

[bedri41]

İlişikte gönderdiğim dosya içerisinde de açıkladığım gibi bir sayfadan diğerine tablo şeklinde veri taşımak istiyorum. Textbox1 e uyan verilerin aktarılması bitince hemen altından Textbox2 ve Textbox3 e uyanları aktarmasını istiyorum.

Yardımcı olacak arkadaşlara şimdiden teşekkür ederim.

 

[Orion1]

Dosyanız ekte.

Dim k As Range, sat As Long, i As Byte, adr As String
Dim sut As Integer, j As Integer
Sheets("OZET").Select
sat = 14
Application.ScreenUpdating = False
Range("A14:F65536").ClearContents
With Sheets("ILLER")
    For i = 1 To 3
        If Controls("TextBox" & i).Value <> "" Then
            Set k = .Range("A:A").Find(Controls("TextBox" & i).Value, , xlValues, xlWhole)
            If Not k Is Nothing Then
                adr = k.Address
                Do
                    Cells(sat, "A").Value = k.Value
                    Cells(sat, "B").Value = k.Offset(0, 1).Value
                    Cells(sat, "C").Value = k.Offset(0, 3).Value
                    Cells(sat, "D").Value = k.Offset(0, 5).Value
                    sut = .Cells(k.Row - 1, 256).End(xlToLeft).Column
                    For j = 7 To sut
                        If Left(Trim(.Cells(k.Row - 1, j).Value), 3) = TextBox4.Text Then
                            If Cells(sat, "E").Value = "" Then Cells(sat, "E").Value = .Cells(k.Row, j).Value
                        End If
                        If Left(Trim(.Cells(k.Row - 1, j).Value), 3) = TextBox5.Text Then
                            If Cells(sat, "F").Value = "" Then Cells(sat, "F").Value = .Cells(k.Row, j).Value
                        End If
                    Next j
                    sat = sat + 1
                    Set k = .Range("A:A").FindNext(k)
                Loop While Not k Is Nothing And k.Address <> adr
                Set k = Nothing
            End If
        End If
    Next i
End With
Application.ScreenUpdating = True
MsgBox "İşlem tamamdır.", vbOKOnly + vbInformation, Application.UserName

 

[bedri41]

Sn. Evren Gizlen, emekleriniz ve yardımlarınız için çok teşekkür ederim. Tabloya yine ILLER sayfasından aktarılacak 2 sutun daha ilave etmem gerekiyor ve bu veriler düzenli şekilde yer almadıkları için yapamadım.
Yardımcı olabilirseniz çok sevinirim.
Teşekkürler

 

[Orion1]

Tam anlayamadım.
2sindenede varsa ikiside aktarılmayacakmı?Birisimi aktarılacak.
Ve diyelim ki 2+1 den birden fazla varsa ne olacak?
Birde 1+2 ler var onlara ne yapılacak 2+1 ler ile ayni işlememi tabi tutulacak?

 

[bedri41]

Haklısınız, Örnekle açıklayayım;
1. sıradaki Adana 3 ve 8 aktarılacak
2. sıradaki Adana 12 ve 4 aktarılacak
3. sıradaki Adana 6 aktarılacak yanı boş kalacak
Adıyaman'da ise 13 ve 63 aktarılacak 21 de kritere uyuyor ama biz soldakini aktaracağız.

1+1 ler veya 1+2 ler de eğer textbox içine yazılıp enterlenirse onların altındaki rakamlar aktarılacak.
Umarım açıklayıcı olmuştur.
Saygılar

 

[Orion1]

offff of bilmem ki ne yapacaz.Sorduğum soruya tam cevap alamadım.Böyle yapar geçerim.Sonra şu böyle olacaktı eksik anlattım demeyin.
Şunuda sordum size 1+2 lerden ve 2+2 lerden birden fazla olursa ne yapılacak?
Ona göre yazacam kodları çünkü bir daha da geri dönmem.

 

[bedri41]

birden fazla olanlarda en soldakini alıcaz. Bunu Adıyaman örneğinde açıklamaya çalışmak istemiştim.
İlgilendiğiniz için gerçekten çok teşekkür ederim.

 

[Orion1]

Tamam.No problem.Hemen kızmayın canım.
Şimdi halletmeye çalışacam.

 

[bedri41]

Kızmak ne haddimize, ne istediğimi tam anlatamayıp vaktinizi aldığım aldığım için üzülebilirim ancak

 

[Orion1]

Textbox4 ve textbox5 te yazacağınız 3 haneli her şeyi sayfada listeleyebilirsiniz.
Dosyanızı 2 numaralı mesajdan indirebilirsiniz.

 

[bedri41]

süper süper süper, ellerinize sağlık çok teşekkür ederim.