2 NOLU KDV ÇALIŞMASI

[Bintang]

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.

 

[Erdem Akdemir]

Merhaba,aşağıdaki kodu kullanabilirsiniz.

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

 

[veyselemre]

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

 

[Bintang]

Merhaba,aşağıdaki kodu kullanabilirsiniz.

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

Üstadım teşekkür ederim ellerinize sağlık

 

[Bintang]

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

Üstadım teşekkür ederim ellerinize sağlık

 

[YUSUF44]

Dün yarım bırakmıştım, şimdi tamamlayabildim, alternatif olsun:

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

 

[spacebar]

sayın Bintang makro ile txt ye çevirip kolaylıkla beyannameye yükleyebilirsiniz. isterseniz yardımcı olabilirim.

 

[Bintang]

sayın Bintang makro ile txt ye çevirip kolaylıkla beyannameye yükleyebilirsiniz. isterseniz yardımcı olabilirim.

Üstadım Merhaba; Elbette çok sevinirim

 

[topal52]

değerli hocalarım benim şu konuyada bi bakabilirmisiniz zamanınız var ise çok teşekkür ederim.

Soru - Veri doğrulama ile başka sayfadan filtreleme yaptırma

Değerli ustalarım sormak istediklerimi ekteki örnek dosyada belirttim yardımcı olabilecek arkadaşlara şimdiden çok teşekkür ederim örnek dosya indirme linki : https://s5.dosya.tc/server4/uv108u/DEMO.xlsm.html

www.excel.web.tr

 

[spacebar]

açıklamalar dosyadadır. iyi çalışmalar dilerim.

 

[Bintang]

açıklamalar dosyadadır. iyi çalışmalar dilerim.

Üstadım çok teşekkür ederim.