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

 

[Bintang]

Lütfen kontrol edip deneyiniz

Üstadım ilk etapta ilgi ve alakanız için teşekkür ederim.
Yanlız ufak bir problem var. Ad - Soyad olarak ayrılması gerekirken
Soyad - Ad olarak ayırıyor. Eğer bunu düzeltmemde yardımcı olursanız çok evinirim.

 

[Bintang]

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

Üstadım çok teşekkür ederim. İyiki varsınız sıkıştığım anda hızır gibi yetişiyorsunuz

 

[muhasebeciyiz]

Sizin paylaştığınız dosyadaki başlıkta Soyadı+adı olarak geçtiği için böyle yapılmıştır.
İsteğinize göre yeniden düzenlenmiştir.

 

[Bintang]

Sizin paylaştığınız dosyadaki başlıkta Soyadı+adı olarak geçtiği için böyle yapılmıştır.
İsteğinize göre yeniden düzenlenmiştir.

Üstadım denedim ama yine eskisi gibi soyad+ ad getiriyor

 

[muhasebeciyiz]

Belki işinize yarar 6 nolu dosyayı güncelledim.

 

[Bintang]

Belki işinize yarar 6 nolu dosyayı güncelledim.

Teşekkür ederim elinize sağlık

 

[Erdem Akdemir]

Merhaba,

Alternatif bir dosya hazırladım. ADO ile hazırladığım için çalışma sayfasındaki başlık isimlerini değiştirdim.

 

[Bintang]

Merhaba,

Alternatif bir dosya hazırladım. ADO ile hazırladığım için çalışma sayfasındaki başlık isimlerini değiştirdim.

Üstadım çok teşekkür ederim. Emeğinize sağlık