2 NOLU KDV BEYANNAMESİ DEĞİŞİKLİĞİ

[Bintang]

Merhaba

Yapmak istediğim

Çalışma Sayfasına Kopya Yapıştır yaptığım değerleri, eski 2 Nolu KDV Beyannamesi ne atmak için AKTAR yapınca

Beyanname Yükleme Sayfasına ( Ünvanı 2 sütuna bölüp atıyor, İsmi ve Soyismi 2 sütune bölüp atıyor, T.C. No ları bir sütune ve Vergi No ları ayrı bir sütune aktarıyordu.)

2 Nolu KDV Beyannamesi değişince Aktarma işlemi ni revize etmem gerekti. Bu sayfada olduğu gibi yine

AKTAR deyince Çalışma sayfasında olan verileri bu sarı boyalı yerlere aktarmasını yapamadım.

Bu konuda yardımcı olursanız sevinirim.

 

[muhasebeciyiz]

Lütfen kontrol edip deneyiniz

 

[Ziynettin]

Alternatif;

Sub test()
Application.ScreenUpdating = False
Dim a(), b1(), b2(), b3()
Dim ws1 As Worksheet, ws2 As Worksheet

Set ws1 = Sheets("Çalışma Sayfası")
Set ws2 = Sheets("Beyanname Yükleme Sayfası_Yeni")

son = ws1.Range("A:A").Find("", , , , xlByRows, xlNext).Row - 1
a = ws1.Range("A1:E" & son).Value

ReDim b1(1 To UBound(a), 1 To 4)
ReDim b2(1 To UBound(a), 1 To 1)
ReDim b3(1 To UBound(a), 1 To 1)

For i = 2 To UBound(a)
    say = say + 1
    x = InStrRev(a(i, 1), " ") - 1
    If x <> -1 Then
        If Len(a(i, 1)) <= 30 Then
            b1(say, 1) = Left(a(i, 1), x)
            b1(say, 2) = Right(a(i, 1), Len(a(i, 1)) - x - 1)
        Else
            y = InStrRev(Left(a(i, 1), 30), " ") - 1
            b1(say, 1) = Left(a(i, 1), y)
            b1(say, 2) = Right(a(i, 1), Len(a(i, 1)) - y - 1)
        End If
        If Len(a(i, 2)) = 11 Then
            b1(say, 3) = a(i, 2)
        Else
            b1(say, 4) = a(i, 2)
        End If
        b2(say, 1) = a(i, 3)
        b3(say, 1) = a(i, 5)
    End If
Next i

ws2.[b2].Resize(say, 4) = b1
ws2.[G2].Resize(say) = b2
ws2.[J2].Resize(say) = b3
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation
End Sub