Hesap kodlarının ayırt edilmesi

[1903emre34@gmail.com]

Merhaba,

Ana hesap bölümün altında yer alan hesap kodlarının ilk üç hanesini yazdırıp tek satırlar halinde gösterilmesini istiyorum, örnek olarak D6 hücresinden başlayıp ara toplam 2 10 bitince yanına 100 hesap kodu, farklı hesap türü ile başlayınca ara toplam 2 13 yanına "131" hesap kodunun yazılması şeklinde nasıl kodla oluşturabiliriz, istenen sayfa 2 yapılmıştır.


http://s9.dosya.tc/server3/p7kbhu/HESAP_1.zip.html

 

[Asri]

Merhaba,

Ana hesap bölümün altında yer alan hesap kodlarının ilk üç hanesini yazdırıp tek satırlar halinde gösterilmesini istiyorum, örnek olarak D6 hücresinden başlayıp ara toplam 2 10 bitince yanına 100 hesap kodu, farklı hesap türü ile başlayınca ara toplam 2 13 yanına "131" hesap kodunun yazılması şeklinde nasıl kodla oluşturabiliriz, istenen sayfa 2 yapılmıştır.
http://s9.dosya.tc/server3/p7kbhu/HESAP_1.zip.html

İstenen sonucu "Sonuc" sayfasına yazacaktır.

Sub aratoplami_al()
Application.DisplayAlerts = False
   Set Sh1 = Sheets("Sayfa1")
   If WorksheetExists("Sonuc") Then
      Sheets("Sonuc").Delete
   End If
   Set Newsh = Sheets.Add(After:=Sheets(Sheets.Count))
   Newsh.Name = "Sonuc"
   Set shsonuc = Sheets("Sonuc")
   
   Sh1.Range("A5:I5").Copy shsonuc.Range("A5")
   sonsatir = Sh1.Cells(Rows.Count, "A").End(3).Row
   satir = 5
   For i = 6 To sonsatir
     veri = Sh1.Cells(i, 1).Value
     oncekiveri = Sh1.Cells(i - 1, 2).Value
     If InStr(veri, "Ara toplam") > 0 Then
        satir = satir + 1
        Sh1.Range("A" & i & ":I" & i).Copy shsonuc.Range("A" & satir)
        shsonuc.Range("B" & satir).Value = Left(oncekiveri, 3)
        shsonuc.Cells(satir, "G").Value = shsonuc.Cells(satir, "E").Value + shsonuc.Cells(satir, "G").Value
        shsonuc.Cells(satir, "E").Value = 0
        shsonuc.Cells(satir, "I").Value = Abs(shsonuc.Cells(satir, "G").Value - shsonuc.Cells(satir, "H").Value)
     End If

   Next i
    shsonuc.Cells.Select
    shsonuc.Cells.EntireColumn.AutoFit
    shsonuc.Range("A1").Select
    
Application.DisplayAlerts = True
End Sub

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
   On Error Resume Next
   WorksheetExists = (Sheets(WorksheetName).Name <> "")
   On Error GoTo 0
End Function

 

[1903emre34@gmail.com]

Asri üstad, teşekkürler sorunsuz çalışıyor, konuyla ilgili olarak bir husus yardımlarınız rica ederim, dosya linki

http://s6.dosya.tc/server10/zp7tnd/HESAP_1.zip.html

 

[Asri]

Asri üstad, teşekkürler sorunsuz çalışıyor, konuyla ilgili olarak bir husus yardımlarınız rica ederim, dosya linki

http://s6.dosya.tc/server10/zp7tnd/HESAP_1.zip.html

Kod güncellendi. Kontrol ediniz.

 

[1903emre34@gmail.com]

Teşekkürler,