Bir tabloyu farklı bir tabloya aktarma

[Ermania]

Merhaba,
Yapmak istediğim bir şey var, çok uğraştım ama ben yapamadım. Yardımcı olabilirseniz çok mutlu olurum.
Ek' e 2 tane excel dosyası koyuyorum.
Yevmiye isimli excel dosyası, programın bana verdiği dosya. (satırı çok olan bir dosya ben çoğunu sildim)
Diğer dosyada Sayıştayın benden istediği taslak. (sarı dolgulu olan yerlere veri girişi yapmıyorum. Boyasız yerleri dolduruyorum)
Ben tek tek kopyala-yapıştır yaparak yevmiye isimli dosyayı diğer dosyaya aktarıyorum.
İşimi kolaylaştıracak bir yöntem olabilir mi acaba?

 

[Ermania]

yokmu dostlar yardımcı olabilecek

 

[ÖmerFaruk]

Verdiğiniz dosyalara göre kod aşağıdadır.

Sub SayıştayaAktar()
    Dim Wb As Workbook, Sh As Worksheet
    Dim YevmiyeNo As Integer, YevmiyeTarihi As Date, Açıklama As String
    Dim i As Integer, k As Integer, ilk As Integer, son As Integer, Say As Integer
    Set Wb = Workbooks("sayıştay.xlsx") 'kitap adı farklıysa burdan değiştirin
    Set Sh = Wb.Worksheets("TASLAK") ' sayfa adı farklıysa buradan değiştirin
    Veri = Range("A1").CurrentRegion.Value
    ReDim Liste1(1 To UBound(Veri), 1 To 6)
    ReDim Liste2(1 To UBound(Veri), 1 To 1)
    For i = 6 To UBound(Veri)
        If Veri(i, 1) = "HESAP KODU" Then
            YevmiyeNo = Split(Veri(i - 1, 1), "-----")(1)
            YevmiyeTarihi = CDate(Split(Veri(i - 1, 1), "-----")(3))
            ilk = i + 1
        End If
        If InStr(1, Veri(i, 1), "FİŞ AÇIKLAMA :") > 0 Then
            son = i
            Açıklama = Veri(i, 2)
        End If
        If ilk > 0 And son > ilk Then
            For k = ilk To son - 1
                Say = Say + 1
                Liste1(Say, 1) = YevmiyeTarihi
                Liste1(Say, 2) = YevmiyeNo
                Liste1(Say, 3) = Veri(k, 2)
                Liste1(Say, 4) = Veri(k, 1)
                Liste1(Say, 5) = Veri(k, 5)
                Liste1(Say, 6) = Veri(k, 6)
                Liste2(Say, 1) = Açıklama
            Next k
            ilk = 0: son = 0
        End If
    Next i
    Sh.Range("G10:L" & Rows.Count).ClearContents
    Sh.Range("R10:R" & Rows.Count).ClearContents
    Sh.Range("G10").Resize(Say, 6) = Liste1
    Sh.Range("R10").Resize(Say, 1) = Liste2
    Set Sh = Nothing: Set Wb = Nothing: Erase Veri: Erase Liste1: Erase Liste2
    i = Empty: k = Empty: ilk = Empty: son = Empty: Say = Empty
    Açıklama = vbNullString: YevmiyeNo = Empty: YevmiyeTarihi = Empty
    MsgBox "İşlem Tamamlanmıştır"
End Sub

 

[Ermania]

Verdiğiniz dosyalara göre kod aşağıdadır.

Sub SayıştayaAktar()
    Dim Wb As Workbook, Sh As Worksheet
    Dim YevmiyeNo As Integer, YevmiyeTarihi As Date, Açıklama As String
    Dim i As Integer, k As Integer, ilk As Integer, son As Integer, Say As Integer
    Set Wb = Workbooks("sayıştay.xlsx") 'kitap adı farklıysa burdan değiştirin
    Set Sh = Wb.Worksheets("TASLAK") ' sayfa adı farklıysa buradan değiştirin
    Veri = Range("A1").CurrentRegion.Value
    ReDim Liste1(1 To UBound(Veri), 1 To 6)
    ReDim Liste2(1 To UBound(Veri), 1 To 1)
    For i = 6 To UBound(Veri)
        If Veri(i, 1) = "HESAP KODU" Then
            YevmiyeNo = Split(Veri(i - 1, 1), "-----")(1)
            YevmiyeTarihi = CDate(Split(Veri(i - 1, 1), "-----")(3))
            ilk = i + 1
        End If
        If InStr(1, Veri(i, 1), "FİŞ AÇIKLAMA :") > 0 Then
            son = i
            Açıklama = Veri(i, 2)
        End If
        If ilk > 0 And son > ilk Then
            For k = ilk To son - 1
                Say = Say + 1
                Liste1(Say, 1) = YevmiyeTarihi
                Liste1(Say, 2) = YevmiyeNo
                Liste1(Say, 3) = Veri(k, 2)
                Liste1(Say, 4) = Veri(k, 1)
                Liste1(Say, 5) = Veri(k, 5)
                Liste1(Say, 6) = Veri(k, 6)
                Liste2(Say, 1) = Açıklama
            Next k
            ilk = 0: son = 0
        End If
    Next i
    Sh.Range("G10:L" & Rows.Count).ClearContents
    Sh.Range("R10:R" & Rows.Count).ClearContents
    Sh.Range("G10").Resize(Say, 6) = Liste1
    Sh.Range("R10").Resize(Say, 1) = Liste2
    Set Sh = Nothing: Set Wb = Nothing: Erase Veri: Erase Liste1: Erase Liste2
    i = Empty: k = Empty: ilk = Empty: son = Empty: Say = Empty
    Açıklama = vbNullString: YevmiyeNo = Empty: YevmiyeTarihi = Empty
    MsgBox "İşlem Tamamlanmıştır"
End Sub

Öncelikle emekleriniz için çok teşekkür ederim. Ben bunu nereye yapıştıracağımı bilemedim. Sayfayı sağ tıklayıp kod görüntüleme ye basıp oraya mı yapıştıracağım?. diğer excel dosyası nerede bulunacak ben tam nasıl kullanacagımı bılemedım ama...

 

[Ermania]

Verdiğiniz dosyalara göre kod aşağıdadır.

Sub SayıştayaAktar()
    Dim Wb As Workbook, Sh As Worksheet
    Dim YevmiyeNo As Integer, YevmiyeTarihi As Date, Açıklama As String
    Dim i As Integer, k As Integer, ilk As Integer, son As Integer, Say As Integer
    Set Wb = Workbooks("sayıştay.xlsx") 'kitap adı farklıysa burdan değiştirin
    Set Sh = Wb.Worksheets("TASLAK") ' sayfa adı farklıysa buradan değiştirin
    Veri = Range("A1").CurrentRegion.Value
    ReDim Liste1(1 To UBound(Veri), 1 To 6)
    ReDim Liste2(1 To UBound(Veri), 1 To 1)
    For i = 6 To UBound(Veri)
        If Veri(i, 1) = "HESAP KODU" Then
            YevmiyeNo = Split(Veri(i - 1, 1), "-----")(1)
            YevmiyeTarihi = CDate(Split(Veri(i - 1, 1), "-----")(3))
            ilk = i + 1
        End If
        If InStr(1, Veri(i, 1), "FİŞ AÇIKLAMA :") > 0 Then
            son = i
            Açıklama = Veri(i, 2)
        End If
        If ilk > 0 And son > ilk Then
            For k = ilk To son - 1
                Say = Say + 1
                Liste1(Say, 1) = YevmiyeTarihi
                Liste1(Say, 2) = YevmiyeNo
                Liste1(Say, 3) = Veri(k, 2)
                Liste1(Say, 4) = Veri(k, 1)
                Liste1(Say, 5) = Veri(k, 5)
                Liste1(Say, 6) = Veri(k, 6)
                Liste2(Say, 1) = Açıklama
            Next k
            ilk = 0: son = 0
        End If
    Next i
    Sh.Range("G10:L" & Rows.Count).ClearContents
    Sh.Range("R10:R" & Rows.Count).ClearContents
    Sh.Range("G10").Resize(Say, 6) = Liste1
    Sh.Range("R10").Resize(Say, 1) = Liste2
    Set Sh = Nothing: Set Wb = Nothing: Erase Veri: Erase Liste1: Erase Liste2
    i = Empty: k = Empty: ilk = Empty: son = Empty: Say = Empty
    Açıklama = vbNullString: YevmiyeNo = Empty: YevmiyeTarihi = Empty
    MsgBox "İşlem Tamamlanmıştır"
End Sub

2 sayfayı açıp yevmiye ye yapıştırdım ve oynat tusuna bastım oldu sanırım?
İyiki varsınız.

 

[ÖmerFaruk]

Söylemeyi unutmuşum pardon.
Evet yaptığınız işlem doğru. Kolay gelsin.