Döngü Kurma

[Araştırıcı]

Selamlar,
Ekteki dosyada ilk sayfadan diğer sayfaya bir butonla veriler aktarılmıştır. Aktarılan olayda yer alan C sütunundaki değerler D sütununda sıralan çizim nesnesinin içersine aaktarılmak istenmektedir. Buna göre:

Aşağıdaki formülleri bir döngü şekline nasıl çevirebilirim? Olayı bir CommandButtona bağlı olarak geliştirebiliriz.

ActiveSheet.Shapes("AutoShape 7").Select
ExecuteExcel4Macro "FORMULA(""=R6C3"")"
ActiveSheet.Shapes("AutoShape 8").Select
ExecuteExcel4Macro "FORMULA(""=R7C3"")"

Yukarıdaki kodlamadan anlaşılacağı gibi C sütununa girilen değerler yukarıdan aşağıya doğru sıralanmaktadır. Bu değerler, aynı ardışık sırada aşağıya doğru sıralanan Shape çizim nesnelerinin (Kare.. ) içersine aktarılacaktır.

Yukarıda sıralanmamış bu olayın yukarıdan aşağıya sıralanmadanki kod oluşumu var. Bunu nasıl geliştirebiliriz. Dosyam ektedir.

Saygılarımla

 

[Araştırıcı]

Dosyayı eklemeden göndermiş oldum. Dosya ektedir.

 

[Araştırıcı]

Değerli ilgililer
iyi akşamlar.

Yukarıdaki konumla ilgili kimse dönüş yapmadı. Genel bu epey bir başıma gelmeye başladı. Bir yanlışımız varsa eleştirileri bekliyorumki hatalı bir şeyler yazayor ya da istiyorsam bunu tekrar etmeyeyim.

Cevap vermek adına değerli zamanlarını veren herekese sonsuz teşekkürler.

 

[Necdet]

Merhaba,

Ne olduğunu anlamadan birşeyler yaptım dener misiniz? Olduysa kendi makronuza ekler misiniz?

Sub Shape_Aktar()
j = 5
For i = 4 To [c65536].End(3).Row
    ActiveSheet.Shapes("AutoShape " & j).Select
    ExecuteExcel4Macro "FORMULA(""=R" & i & "C3"")"
    j = j + 1
Next
End Sub

 

[Korhan Ayhan]

Selamlar,

Örnek dosyanızdaki kodu aşağıdaki şekilde değiştirip denermisiniz.

Sub AktarTopla()
    Dim a, n As Long, i As Long, z As Object, MyKeys(), MyItems()
    Set s1 = Sheets("SEMT")
    Set s2 = Sheets("LISTE")
    Application.ScreenUpdating = False
    s2.Range("a4:c2000").ClearContents
    '*******************************************************
    a = s1.[b3:I2000]
    Set z = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a, 1)
    If a(i, 8) = s2.[b1] Then
    If Not z.exists(a(i, 1)) Then
    z.Add a(i, 1), a(i, 2)
    Else
    z.Item(a(i, 1)) = z.Item(a(i, 1)) + a(i, 2)
    End If
    End If
    Next i
    For i = 1 To z.Count
    s2.Cells(i + 3, "a").Value = i
    Next i
    s2.[b4].Resize(z.Count, 2) = Application.Transpose(Array(z.keys, z.items))
    '*******************************************************
    s2.Select
    Range("b4:h100").Select
    Selection.Sort Key1:=Range("d3")
    For X = 4 To [A65536].End(3).Row
    ActiveSheet.Shapes("AutoShape " & X + 1).Select
    Selection.Formula = "=" & Cells(X, 3).Address & ""
    Next
    Range("a1").Select
    Application.ScreenUpdating = True
    MsgBox "Bitti"
    Set z = Nothing
    Set s1 = Nothing
    Set s2 = Nothing
End Sub

 

[Araştırıcı]

Merhaba,

İşlerinizin hep rast gitsin. Çok makbule geçti inanılmaz faydası oldu.Emeğinize elinize sağlık.

Saygılarımla