Başka sayfaya veri toplayıp aktarma

[akmes]

Üstadım selamlar,Ektede size ilettiğim örnekte anlaşılacağı gibi, ilk sayfada olan bazı verilerin toplamını ikinci sayfaya aktarmak istiyoruz.Dekonttan girdiğimiz faturaların 320 ye sadece matrahını yazdırmasını istiyoruz.A sütününda belgenin ft nosu mevcut.Burada sadece 320 ve 191 i toplamadan arka sayfaya iligili 320 ye matrahını yazması gbi..Şimdiden ilginiz için teşekkür ederim

 

[Ferhat Pazarçevirdi]

Merhabalar

Aşağıdaki kodları bir makroya atayarak işlemi gerçekleştirebilirsiniz.

Sub Diger_Sayfaya_Aktar()
Dim rng As Range     [COLOR="Green"]'Aranan hücre[/COLOR]
Dim sh1 As Worksheet [COLOR="green"]'Ham verilerin olduğu çalışma sayfası[/COLOR]
Dim sh2 As Worksheet[COLOR="green"] 'Aktarım yapılacak çalışma sayfası[/COLOR]

Dim iStr As Integer  [COLOR="green"]'Diğer sayfaya satır satır yazdırmak için kullanılacak [/COLOR]değişken
Dim iBul As Integer  [COLOR="green"]'Arama sonucu bulunan satır no[/COLOR]
Dim sAdr As String   [COLOR="green"]'Bulunan hücrenin adresi[/COLOR]

Set sh1 = Worksheets("Sayfa1")
Set sh2 = Worksheets("Sayfa2")

[COLOR="green"]'Verilerin aktarılacağı sayfa temizleniyor[/COLOR]
sh2.Cells.Clear
[COLOR="green"]'Başlık satırları kopyalanıyor[/COLOR]
sh1.Range("A2:H2").Copy sh2.Range("A1:H1")

'[COLOR="green"]"Kayıt Sayısı" adlı hücre değeri aranıyor[/COLOR]
Set rng = sh1.Columns(1).Find("Kayıt Sayısı", lookat:=xlWhole)

[COLOR="green"]'Eğer bulunduysa[/COLOR]
If Not rng Is Nothing Then

    iStr = 2
    sAdr = rng.Address
    iBul = rng.Row

    Do
       [COLOR="green"] 'Eğer ilgili CH'de hareket kaydı varsa[/COLOR]
        If sh1.Range("A" & iBul - 1) <> "Fiş No" Then
            [COLOR="green"]'Bulunan hücrenin bir satır üstündeki verileri diğer sayfaya aktar[/COLOR]
            sh1.Range("A" & iBul - 1 & ":H" & iBul - 1).Copy sh2.Range("A" & iStr & ":H" & iStr)
        End If
        
        [COLOR="green"]'Başka CH aramaya devam et[/COLOR]
        Set rng = sh1.Columns(1).FindNext(rng)
    
       [COLOR="green"] 'Diğer sayfada yeni satır değişkenini ayarla[/COLOR]
        iStr = iStr + 1: iBul = rng.Row
    
    [COLOR="green"]'Ta ki, aranan olmayana veya ilk bulunan adresle yeni bulunan adres aynı olana kadar[/COLOR]
    Loop Until rng Is Nothing Or sAdr = rng.Address
End If

Set rng = Nothing
Set sh1 = Nothing
Set sh2 = Nothing

End Sub

 

[akmes]

Üstadım emeğinize sağlık,teşekkür ederim.

 

[akmes]

üstadım makro sorunsuz çalıştı ama birşey daha düzeltme imkanımız varmı?Sadece Tutar kısmında sayfa 2 ye atılan değerden sayfa 1 deki 191 le başlayan hücerlerin tutar kısımları çıkarılarak sayfa 2 ye yazılması mümkün mü? bu makroda aktarılan 811,16 ama 811,16-60,09 yapıp o değeri aktarmasını sağlayabirsek süper olur.

 

[Ferhat Pazarçevirdi]

Şu şekilde kodu değiştiriniz. Kırmızı ile belirttiğim kısmı ilave ettim.

Sub Diger_Sayfaya_Aktar()
Dim rng As Range
Dim sh1 As Worksheet
Dim sh2 As Worksheet

Dim iStr As Integer
Dim iBul As Integer
Dim sAdr As String

Set sh1 = Worksheets("Sayfa1")
Set sh2 = Worksheets("Sayfa2")

sh2.Cells.Clear
sh1.Range("A2:H2").Copy sh2.Range("A1:H1")

Set rng = sh1.Columns(1).Find("Kayıt Sayısı", lookat:=xlWhole)

If Not rng Is Nothing Then

    iStr = 2
    sAdr = rng.Address
    iBul = rng.Row

    Do
        If sh1.Range("A" & iBul - 1) <> "Fiş No" Then
            sh1.Range("A" & iBul - 1 & ":H" & iBul - 1).Copy sh2.Range("A" & iStr & ":H" & iStr)
            
[COLOR="Red"]            sh2.Range("D" & iStr) = sh2.Range("D" & iStr) - sh1.Range("D" & iBul - 2)[/COLOR]
        
        End If
        
        Set rng = sh1.Columns(1).FindNext(rng)
    
        iStr = iStr + 1: iBul = rng.Row
    
    Loop Until rng Is Nothing Or sAdr = rng.Address
End If

Set rng = Nothing
Set sh1 = Nothing
Set sh2 = Nothing

End Sub

 

[akmes]

Üstadım eline koluna, emeğine sağlık,çok güzel oldu.Teşekkür ederim.