Butona basınca listedeki sıra numarasını bir artırma

[kahramang1]

Arkadaşlar ben makrodan anlamam. Ekli tabloda makro kaydet özelliği ile birşeyler yapmaya çalıştım. Ricam şudur. Liste sayfasına yeni bir satır girip "aktar" butonuna bastığımda sıra numarası sütunundaki sayıyı bir artırsın. Ben listeye formül kurduğumda makro bozuluyor. yani aktar butonuna bastığımda veri kaybı olmadan aktarmanın gerçekleşip, numaranın bir artmasıdır ricam. Bu konuda yardımcı olursanız sevinirim. Kolay gelsin.
https://drive.google.com/file/d/0B7rifb6G0ZlIWmRKTmt0cHRWYlU/view?usp=sharing

 

[Asri]

Her bir yetkili, malik ve makbuz listesi için 100000 satır limitlidir.Eksiltilip arttırılabilir.

http://dosya.co/4klcj8mgo9tm/tahsilatMakbuzu_aktarmalı.xlsm.html

Dim yetkililistesi(100000, 2) As String
Dim maliklistesi(100000, 2) As String
Dim liste(100000, 5) As String
Dim listesay, maliksay, yetkisay As Long

Sub menu()
Application.ScreenUpdating = False
    Call yetki_yukle
    Call malik_yukle
    Call liste_yukle
    Call aktar
 Application.ScreenUpdating = True
End Sub

Sub aktar()
    Sheets("makbuz").Select
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    If sonsatir > 17 Then
       Rows("18:" & sonsatir).Delete
    End If
    
    For i = 1 To listesay
       [F1] = liste(i, 1)
       [F2] = liste(i, 2)
       [A7] = liste(i, 3)
       [D6] = liste(i, 4)
       [A15] = liste(i, 5)
       [A8] = YAZIYACEVIR(liste(i, 4)) & " tahsil edilmiştir."
       
       For j = 1 To maliksay
         If liste(i, 3) = maliklistesi(j, 1) Then
            [D7] = maliklistesi(j, 2)
            Exit For
         End If
       Next j
       
       For j = 1 To yetkisay
         If [C11] = yetkililistesi(j, 1) Then
            [C12] = yetkililistesi(j, 2)
            Exit For
         End If
       Next j
       
       If i <> listesay Then
         Rows("1:17").Select
         Selection.Copy
         Selection.Insert Shift:=xlDown
         Range("A1:C1").Select
         Application.CutCopyMode = False
       End If
       
    Next i
End Sub

Sub liste_yukle()
   Sheets("liste").Select
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   For i = 2 To sonsatir
       liste(i - 1, 1) = Cells(i, 1).Value
       liste(i - 1, 2) = Cells(i, 2).Value
       liste(i - 1, 3) = Cells(i, 3).Value
       liste(i - 1, 4) = Cells(i, 4).Value
       liste(i - 1, 5) = Cells(i, 5).Value
       listesay = i - 1
   Next i
End Sub

Sub yetki_yukle()
   Sheets("yetkili listesi").Select
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   For i = 2 To sonsatir
     yetkililistesi(i - 1, 1) = Cells(i, 1).Value
     yetkililistesi(i - 1, 2) = Cells(i, 2).Value
     yetkisay = i - 1
   Next i
End Sub

Sub malik_yukle()
   Sheets("malik listesi").Select
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   For i = 2 To sonsatir
     maliklistesi(i - 1, 1) = Cells(i, 1).Value
     maliklistesi(i - 1, 2) = Cells(i, 2).Value
     maliksay = i - 1
   Next i
End Sub

Public Function YAZIYACEVIR(Para_Tutar)

Dim Para_TutarStr As String
Dim ParaBirimi As String, ParaAltBirimi As String


If Para_Tutar = "" Then
YAZIYACEVIR = HücreAdı & " Hücresine bir değer girmelisiniz !..."
Exit Function
End If

If Not IsNumeric(Para_Tutar) Then
YAZIYACEVIR = HücreAdı & " Hücresine girilen değer, sayı değil !..."
Exit Function
End If

ParaStr = Format(Abs(Para_Tutar), "0.00")
ParaBirimi = Left(ParaStr, Len(ParaStr) - 3)
ParaAltBirimi = Right(ParaStr, 2)

YAZIYACEVIR = IIf(Para_Tutar = 0, "Yalnız " & Cevir(ParaBirimi) & " TL ", "") & _
IIf(Para_Tutar <> 0, "Yalnız ", "") & _
IIf(Para_Tutar < 0, "Eksi (-) ", "") & _
IIf(Para_Tutar <> 0, Cevir(ParaBirimi) & " TL ", "") & _
IIf(Val(ParaAltBirimi) <> 0, Cevir(ParaAltBirimi) & " Kuruş.", "")

If ParaBirimi = 0 And ParaAltBirimi > 0 Then
YAZIYACEVIR = "Yalnız " & Cevir(ParaAltBirimi) & " Kuruş."

If Para_Tutar < 0 And ParaAltBirimi > 0 Then
YAZIYACEVIR = "Yalnız Eksi (-) " & Cevir(ParaAltBirimi) & " Kuruş."

End If

End If

End Function

Private Function Cevir(SayiStr As String) As String

Dim Rakam(15)
Dim c(3), Sonuc, e

Birler = Array("", "bir", "iki", "üç", "dört", "beş", "altı", "yedi", "sekiz", "dokuz")
Onlar = Array("", "on", "yirmi", "otuz", "kırk", "elli", "altmış", "yetmiş", "seksen", "doksan")
Binler = Array("trilyon", "milyar", "milyon", "bin", "")

SayiStr = String(15 - Len(SayiStr), "0") + SayiStr

For i = 1 To 15
Rakam(i) = Val(Mid$(SayiStr, i, 1))
Next i

Sonuc = ""
For i = 0 To 4
c(1) = Rakam(i * 3 + 1)
c(2) = Rakam(i * 3 + 2)
c(3) = Rakam(i * 3 + 3)
If c(1) = 0 Then
e = ""
ElseIf c(1) = 1 Then
e = "yüz"
Else
e = Birler(c(1)) + "yüz"
End If
e = e + Onlar(c(2)) + Birler(c(3))
If e <> "" Then e = e + Binler(i)
If (i = 3) And (e = "birbin") Then e = "bin"
Sonuc = Sonuc + e
Next i

If Sonuc = "" Then Sonuc = "Sıfır"

Cevir = UCase(Mid(Sonuc, 1, 1)) + Mid(Sonuc, 2, Len(Sonuc) - 1)
End Function

 

[kahramang1]

İlginiz için teşekkürler. lakin istediğim tam olarak bu değil. Makbuz sayfasında çoğaltma yapmayacak. o sayfada altta olan makbuz diğerinin kopyası zaten. ben ikisini bir a5 e yazdırıp, ortadan yırtıyorum. Makbuz sayfası da verileri liste sayfasından alıyor. Ben verileri listeye yazıp aktar tuşuna basınca makbuz oluşuyor ve yazdırıyorum. Tam olarak istediğim liste sayfasına veri girip aktar dediğimde, verileri aktarıp, sıra numarasını bir artırmasıdır. Teşekkürler.

 

[kahramang1]

Birde benim vermiş olduğunuz kodu benim birşey yapmam lazımmı. yoksa sadece dosyayı indirmem yeterli mi. gerçi böyle daha güzel olmuş. Makbuzu 2 nüsha aktarabilir miyiz acaba?