Hesaplara Dağıtma

[mars2]

İyi Akşamlar;

Aktar isimli çalışma kitabımın 2. sayfasında, dosyalarına göre toplam bedeller ve hesap noları bulunmaktadır. 3 Sayfada ise 2 sayfadan B sutundaki Dosya nolarını, 3 sayfanın B sutununa, C sutunundaki Hesap Nolarını 3 sayfanın C sutununa, E sutunundaki % 65'i 3 sayfanın E sutununa ve F sutunundaki %35 tuatarlarını da 3 sayfanın F sutununa aktarmak istiyorum. Ancak, 2. sayfada bulunan hesaplarında bazılarında 2 ve 3 adet hesap bulunmakta olup, 3 sayfada ise bunları alt alta yazdırarak bedeli de 2 ise 2'ye 3 ise 3'e bölerek aktarmak istiyorum.
Bu uygulamaya ait örnek ekte olup yardımlarınız beklenmektedir.

 

[muhasebeciyiz]

deneyiniz

 

[mars2]

İyi Günler;
Sayın muhasebeciyiz, ilginize teşekkürler, cevabınıza işlerin yoğunluğu nedeniyle bakamamıştımn.

Modulde bulunan kodunu çalıştırdığımda, Dosya nosu sutununda ("B") sıra nosu, Hesap nosunun bulunduğu sutunda ise ("c") sutununa ise hesa noları gelmektedir.

Aşağdaki kodunuzda bulunna satırları
For j = 0 To UBound(arr)

s3.Cells(outRow, 2).Value = sira
s3.Cells(outRow, 3).Value = dosya
s3.Cells(outRow, 4).Value = arr(j)

s3.Cells(outRow, 6).Value = tut65 / adet
s3.Cells(outRow, 7).Value = tut35 / adet

outRow = outRow + 1
sira = sira + 1

Yine aşağıdaki değiştirdiğimde sorun kalmamktadır.

s3.Cells(outRow, 2).Value = dosya
s3.Cells(outRow, 3).Value = hesap
s3.Cells(outRow, 3).Value = arr(j)

s3.Cells(outRow, 5).Value = tut65 / adet
s3.Cells(outRow, 6).Value = tut35 / adet
outRow = outRow + 1
sira = sira + 1

Ancak, kendi çalışma kitabımında uyguladığım zamam "Automatioın error özel durıum oluştu" mesajı çıkarak excel kapanıp yeniden açılmaktadır. sorun neerden kaynaklanmaktadır.

Ayrıca, A4 ile B4 ve A5 ile B5 hücrelerin birleştirilmesinde herhangşi bir sorunla karşılkaşmamızda neden olabilir mi

 

[Korhan Ayhan]

Alternatif olsun..

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Last_Row As Long, Rng As Range
    Dim Hesap As Variant, No As Long
    Dim Say As Byte
    
    Set S1 = Sheets("Sayfa2")
    Set S2 = Sheets("Sayfa3")
    
    Application.ScreenUpdating = False
    
    S2.Range("A8:G" & S2.Rows.Count).Clear
    
    Last_Row = S1.Cells(S1.Rows.Count, 2).End(3).Row
    
    For Each Rng In S1.Range("B3:G" & Last_Row).Columns(2).Cells
        If Rng.Value <> "" Then
            Say = UBound(Split(Rng.Value, "-")) + 1
            For Each Hesap In Split(Rng.Value, "-")
                No = No + 1
                S2.Cells(No + 7, 1) = No
                S2.Cells(No + 7, 2) = Rng.Offset(, -1)
                S2.Cells(No + 7, 3) = Hesap
                S2.Cells(No + 7, 5) = Rng.Offset(, 2) / Say
                S2.Cells(No + 7, 6) = Rng.Offset(, 3) / Say
                S2.Cells(No + 7, 7) = Rng.Offset(, 4)
            Next
        End If
    Next
    
    With S2.Range("A8:G" & No + 7)
        .Borders.LineStyle = 1
        .HorizontalAlignment = 3
    End With
        
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub