• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

2 NOLU KDV ÇALIŞMASI

Bintang

Bintang

Altın Üye
Katılım
31 Ekim 2006
Mesajlar
363
Excel Vers. ve Dili
Microsoft Office Professional Plus 2019,Türkçe
Merhaba; 2 nolu KDV Beyannamesi son kanun değişikliklerinden sonra oldukça zorlaştı. Bende kendimce bir çalışma yaptım ancak makro ile bunu tabloya yerleştirme işini beceremedim Acaba bana bu konuda yardımcı olabilirmisiniz.
 

Ekli dosyalar

Merhaba,aşağıdaki kodu kullanabilirsiniz.

Kod: 
Sub kdv2()

Dim data As Worksheet

son = Sheets("Çalışma Sayfası").Range("A1").End(4).Row
Sheets("Beyanname Yükleme Sayfası").Cells.ClearContents

Set data = Sheets("Çalışma Sayfası")

For i = 2 To son

With Sheets("Beyanname Yükleme Sayfası")

    .Cells(i, 1) = Trim(VBA.Left(data.Cells(i, 1), 30))
    .Cells(i, 2) = Trim(VBA.Mid(data.Cells(i, 1), 31, 30))
    If Len(data.Cells(i, 2)) = 11 Then .Cells(i, 3) = data.Cells(i, 2)
    If Len(data.Cells(i, 2)) = 10 Then .Cells(i, 4) = data.Cells(i, 2)
   .Cells(i, 5) = data.Cells(i, 3)
   .Cells(i, 6) = data.Cells(i, 5)
  
End With

Next i

End Sub
 
Kod: 
Sub test()
    Set s1 = Sheets("Beyanname Yükleme Sayfası")
    Set s2 = Sheets("Çalışma Sayfası")
    son2 = s2.Cells(Rows.Count, 1).End(3).Row
    s1.Rows("2:" & Rows.Count).ClearContents
    For i = 2 To son2
        bl = Split(s2.Cells(i, 1).Value, " ")
        If UBound(bl) = 1 Then
            s1.Cells(i, 1).Value = bl(0)
            s1.Cells(i, 2).Value = bl(1)
        Else
            b = ""
            For ii = 0 To UBound(bl)
                If (Len(b) + Len(bl(ii))) < 30 Then
                    b = Trim(b & " " & bl(ii))
                    bl(ii) = ""
                End If
            Next ii
            s1.Cells(i, 1).Value = b
            s1.Cells(i, 2).Value = Left(Trim(Join(bl)), 30)
        End If
        If Len(s2.Cells(i, 2).Value) = 11 Then
            s1.Cells(i, 3).Value = s2.Cells(i, 2).Value
        Else
            s1.Cells(i, 4).Value = s2.Cells(i, 2).Value
        End If
        s1.Cells(i, 5).Value = s2.Cells(i, 3).Value
        s1.Cells(i, 6).Value = s2.Cells(i, 5).Value
    Next i
End Sub
 
Erdem Akdemir' Alıntı:
Merhaba,aşağıdaki kodu kullanabilirsiniz.

Kod: 
Sub kdv2()

Dim data As Worksheet

son = Sheets("Çalışma Sayfası").Range("A1").End(4).Row
Sheets("Beyanname Yükleme Sayfası").Cells.ClearContents

Set data = Sheets("Çalışma Sayfası")

For i = 2 To son

With Sheets("Beyanname Yükleme Sayfası")

    .Cells(i, 1) = Trim(VBA.Left(data.Cells(i, 1), 30))
    .Cells(i, 2) = Trim(VBA.Mid(data.Cells(i, 1), 31, 30))
    If Len(data.Cells(i, 2)) = 11 Then .Cells(i, 3) = data.Cells(i, 2)
    If Len(data.Cells(i, 2)) = 10 Then .Cells(i, 4) = data.Cells(i, 2)
   .Cells(i, 5) = data.Cells(i, 3)
   .Cells(i, 6) = data.Cells(i, 5)
 
End With

Next i

End Sub
Genişletmek için tıkla ...
Üstadım teşekkür ederim ellerinize sağlık
 
veyselemre' Alıntı:
Kod: 
Sub test()
    Set s1 = Sheets("Beyanname Yükleme Sayfası")
    Set s2 = Sheets("Çalışma Sayfası")
    son2 = s2.Cells(Rows.Count, 1).End(3).Row
    s1.Rows("2:" & Rows.Count).ClearContents
    For i = 2 To son2
        bl = Split(s2.Cells(i, 1).Value, " ")
        If UBound(bl) = 1 Then
            s1.Cells(i, 1).Value = bl(0)
            s1.Cells(i, 2).Value = bl(1)
        Else
            b = ""
            For ii = 0 To UBound(bl)
                If (Len(b) + Len(bl(ii))) < 30 Then
                    b = Trim(b & " " & bl(ii))
                    bl(ii) = ""
                End If
            Next ii
            s1.Cells(i, 1).Value = b
            s1.Cells(i, 2).Value = Left(Trim(Join(bl)), 30)
        End If
        If Len(s2.Cells(i, 2).Value) = 11 Then
            s1.Cells(i, 3).Value = s2.Cells(i, 2).Value
        Else
            s1.Cells(i, 4).Value = s2.Cells(i, 2).Value
        End If
        s1.Cells(i, 5).Value = s2.Cells(i, 3).Value
        s1.Cells(i, 6).Value = s2.Cells(i, 5).Value
    Next i
End Sub
Genişletmek için tıkla ...
Üstadım teşekkür ederim ellerinize sağlık
 
Dün yarım bırakmıştım, şimdi tamamlayabildim, alternatif olsun:

Kod: 
Sub kdv()
Dim kisi() ' As Variant
Set s1 = Sheets("Beyanname Yükleme Sayfası")
Set s2 = Sheets("Çalışma Sayfası")
eski = s1.Cells(Rows.Count, "A").End(3).Row
If eski > 1 Then s1.Range("A2:F" & eski).ClearContents
son = s2.Cells(Rows.Count, "A").End(3).Row
If son < 2 Then Exit Sub
Application.ScreenUpdating = False
    For i = 2 To son
        If s2.Cells(i, "B") <> "" Then
            yeni = s1.Cells(Rows.Count, "A").End(3).Row + 1
            If Len(s2.Cells(i, "B")) = 11 Then
                s1.Cells(yeni, "A") = Left(s2.Cells(i, "A"), WorksheetFunction.Find(" ", s2.Cells(i, "A")) - 1)
                s1.Cells(yeni, "B") = Right(s2.Cells(i, "A"), Len(s2.Cells(i, "A")) - WorksheetFunction.Find(" ", s2.Cells(i, "A")) - 1)
                s1.Cells(yeni, "C") = s2.Cells(i, "B")
            Else
                If Len(s2.Cells(i, "A")) > 30 Then
                    s1.Cells(yeni, "A") = Left(s2.Cells(i, "A"), 30)
                    s1.Cells(yeni, "B") = Right(s2.Cells(i, "A"), Len(s2.Cells(i, "A")) - 30)
                Else
                    s1.Cells(yeni, "A") = s2.Cells(i, "A")
                End If
                s1.Cells(yeni, "D") = s2.Cells(i, "B")
            End If
            
            s1.Cells(yeni, "E") = s2.Cells(i, "C")
            s1.Cells(yeni, "F") = s2.Cells(i, "E")
        End If
    Next
Application.ScreenUpdating = True

End Sub
 
sayın Bintang makro ile txt ye çevirip kolaylıkla beyannameye yükleyebilirsiniz. isterseniz yardımcı olabilirim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst