mizan sayfasındaki bakiyeleri bilanço sayfasına aktarma

[spacebar]

değerli üstadlarım ,
mizan sayfasında A sutununda 3 haneli olan hesapların E sutunundaki karşılığı olan rakamları,
bilanço sayfasında (hesap numaraları karşılığı K sutununda olan hesapları) B sutununa getirmek istiyorum.

örnek : mizan sayfasında A4 hücresindeki 100 hesap kodunun E sutundaki değeri olan 15.532,74 rakamını bilanço sayfasında K sutununda bulup bunu B sutunundaki hücreye (yani B5 hücresine) getirmesini istiyorum.
bu şekilde 100 den 591 nolu hesaba kadar devam etmesi gerekiyor.

desteğiniz için teşekkürler…

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

 

[Korhan Ayhan]

Alternatif,

DİZİ yöntemi kullanılmıştır. Hız olarak avantaj sağlayacaktır.

Option Explicit

Sub Bakiye_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object, Say As Long
    Dim Veri As Variant, X As Long, Son As Long, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("Mizan")
    Set S2 = Sheets("Bilanço")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son = 2 Then Son = 3
    
    Veri = S1.Range("A1:E" & Son).Value
    
    For X = LBound(Veri) To UBound(Veri)
        If Len(Veri(X, 1)) = 3 Then
            Dizi.Add Veri(X, 1), Veri(X, 5)
        End If
    Next
    
    Son = S2.Cells(S2.Rows.Count, 11).End(3).Row
    If Son = 2 Then Son = 3
    
    Veri = S2.Range("K5:K" & Son).Value
    
    ReDim Liste(1 To Son - 4, 1 To 1)
    
    For X = LBound(Veri) To UBound(Veri)
        Say = Say + 1
        If Dizi.Exists(Veri(X, 1)) Then
            Liste(Say, 1) = Dizi.Item(Veri(X, 1))
        Else
            Liste(Say, 1) = ""
        End If
    Next

    S2.Range("B5:B110,B112:B219,B224:B332,B334:B440,B442:B538").ClearContents
    
    If Say > 0 Then
        S2.Range("B5").Resize(Say) = Liste
        MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    End If

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
End Sub

 

[spacebar]

üstad mükemmel çalışıyor. ellerinize sağlık. çok teşekkür ederim. sağlıklı günler dilerim...

 

[spacebar]

Merhaba;
Eki deneyin.
İyi çalışmalar.

üstad ben son mesaja odaklanmışım yeni farktettim. kusura bakmayın. teşekkür ederim.