Excel sayfası Düzenleme

[umit1907]

Merhabalar,
ekte belirtmiş olduğum sayfada data sayfasında hesap kodlarının olduğu satırlar var bunların uzunlukları hesap hareketlerine göre değişiklik göstermektedir yapmak istediğim hesap kodlarını tarih kolanlarının yanına yazdırmak. Yardımlarınız için şimdiden teşekkürler.

 

[Trilenium]

Sub AktarVeriler()
Dim wsVeri As Worksheet
Dim wsRapor As Worksheet
Dim lastRow As Long
Dim raporRow As Long
Dim i As Long
Dim hesapAdi As String

Set wsVeri = ThisWorkbook.Sheets("Veri")
Set wsRapor = ThisWorkbook.Sheets("Rapor")

' Rapor sayfasına başlıkları yazalım
wsRapor.Range("A1:M1").Value = Array("Hesap Kodu", "Tarih", "Fiş No", "Sıra", "Fatura No", "Açıklama", "Yevm.No", "Cari No", "Vade Tarihi", "TL Borç", "TL Alacak", "Borç Bak.", "Alacak Bak.")

' Veri sayfasındaki son satırı bul
lastRow = wsVeri.Cells(wsVeri.Rows.Count, "B").End(xlUp).Row

raporRow = 2

' Verileri "Rapor" sayfasına aktaralım
For i = 6 To lastRow
If wsVeri.Range("B" & i & ":L" & i).MergeCells Then
hesapAdi = wsVeri.Range("B" & i).Value
i = i + 4 ' Birleştirilmiş hücrelerin 3 satır sonrasını işlemek için artır
Do While i <= lastRow
' Boş satır ve genel toplam kontrolü
If wsVeri.Cells(i, 2).Value = "" And wsVeri.Cells(i, 3).Value = "" And wsVeri.Cells(i, 4).Value = "" _
And wsVeri.Cells(i, 6).Value = "" And wsVeri.Cells(i, 8).Value = "" And wsVeri.Cells(i, 10).Value = "" _
And wsVeri.Cells(i, 11).Value = "" And wsVeri.Cells(i, 13).Value = "" And wsVeri.Cells(i, 15).Value = "" _
And wsVeri.Cells(i, 16).Value = "" And wsVeri.Cells(i, 17).Value = "" And wsVeri.Cells(i, 18).Value = "" _
Or (wsVeri.Cells(i, 11).MergeCells And wsVeri.Cells(i, 12).MergeCells And wsVeri.Cells(i, 13).MergeCells) Then
Exit Do
End If

wsRapor.Cells(raporRow, 1).Value = hesapAdi
wsRapor.Cells(raporRow, 2).Value = wsVeri.Cells(i, 2).Value ' Tarih
wsRapor.Cells(raporRow, 3).Value = wsVeri.Cells(i, 3).Value ' Fiş No
wsRapor.Cells(raporRow, 4).Value = wsVeri.Cells(i, 4).Value ' Sıra
wsRapor.Cells(raporRow, 5).Value = wsVeri.Cells(i, 6).Value ' Fatura No
wsRapor.Cells(raporRow, 6).Value = wsVeri.Cells(i, 8).Value ' Açıklama
wsRapor.Cells(raporRow, 7).Value = wsVeri.Cells(i, 10).Value ' Yevm.No
wsRapor.Cells(raporRow, 8).Value = wsVeri.Cells(i, 11).Value ' Cari No
wsRapor.Cells(raporRow, 9).Value = wsVeri.Cells(i, 13).Value ' Vade Tarihi
wsRapor.Cells(raporRow, 10).Value = wsVeri.Cells(i, 15).Value ' TL Borç
wsRapor.Cells(raporRow, 11).Value = wsVeri.Cells(i, 16).Value ' TL Alacak
wsRapor.Cells(raporRow, 12).Value = wsVeri.Cells(i, 17).Value ' Borç Bak.
wsRapor.Cells(raporRow, 13).Value = wsVeri.Cells(i, 18).Value ' Alacak Bak.

raporRow = raporRow + 1
i = i + 1
Loop
End If
Next i

MsgBox "Veriler başarıyla aktarılmıştır.", vbInformation
End Sub

 

[Ziynettin]

Alternatif.

Sub test()
Dim s1 As Worksheet, s2 As Worksheet

Set s1 = Sheets("VERİ")
Set s2 = Sheets("Sonuc")

son = s1.Range("B" & Rows.Count).End(3).Row
a = s1.Range("A1:R" & son).Value

ReDim b(1 To UBound(a), 1 To 13)
col = Array(2, 3, 4, 6, 8, 9, 11, 13, 15, 16, 17, 18)
    For i = 1 To UBound(a)
    If Right(a(i, 2), 5) = " KASA" Then p = a(i, 2)
    If p <> "" Then y = p
    If IsDate(a(i, 2)) = True Then
        say = say + 1
        b(say, 1) = y
        For j = 0 To UBound(col)
            b(say, j + 2) = a(i, Val(col(j)))
        Next j
    End If
    Next i
s2.Range("A2:M" & Rows.Count).ClearContents
s2.Range("A2:M" & Rows.Count).ClearFormats

If say > 0 Then
    s2.[B2].Resize(say).NumberFormat = "dd.mm.yyyy"
    s2.[A2].Resize(say, 13) = b
    s2.[A2].Resize(say, 13).Borders.Color = rgbSilver
End If

MsgBox "İşlem tamam.", vbInformation

End Sub

 

[umit1907]

Çok Teşekkürler İkiside birbirinden güzel olmuş elinize sağlık