farklı iki sayfadaki verileri bir sayfaya aktarmak

[gedavet]

iyi çalışmalar

satış ve gelir sayfasındaki verileri rapor sayfasına aktarıp özet taplosu almak istiyorum bu aktaramayı yapıverebilirmisiniz her sayfanın verileri ayrı satıra akratılması lazım verilerin çok olduğunu düşünürsek önce satışı aktarıp sonrada geliri akrata bilir bu önemli değil ancak veiler sağlıklı olması lazım
yardımcı olabilirmisiniz

 

[gedavet]

Sub GELİR_SAYFALARINI_BİRLEŞTİR()
Dim S1 As Worksheet, SAYFA As Worksheet, SATIR As Integer, SAY As Integer
Dim X As Byte, AYLAR() As Variant

Set S1 = Sheets("YILLIK GELİR")
AYLAR = Array("OCAK", "ŞUBAT", "MART", "NİSAN", "MAYIS", "HAZİRAN", "TEMMUZ", "AĞUSTOS", "EYLÜL", "EKİM", "KASIM", "ARALIK")

Application.ScreenUpdating = False

S1.Range("C6:H6005").ClearContents

For X = 0 To 11
Set SAYFA = Sheets(AYLAR(X) & " GELİR")
If S1.Range("C6005") <> "" Then GoTo Son
If SAYFA.Range("C6") = "" Then GoTo Devam
If SAYFA.Range("C505") <> "" Then
SATIR = S1.Cells(6006, "D").End(3).Offset(0, -1).Row
If (SATIR - 5 + 500) > 6000 Then GoTo Son
S1.Range("C6:H" & SATIR + 500).Value = SAYFA.Range("C6:H505").Value
Else
SATIR = S1.Cells(6006, "D").End(3).Offset(0, -1).Row
SAY = SAYFA.Range("D506").End(3).Row - 5
If (SATIR - 5 + SAY) > 6000 Then GoTo Son
S1.Range("C" & SATIR + 1 & ":H" & SATIR + SAY).Value = SAYFA.Range("C6:H" & SAYFA.Range("D506").End(3).Row).Value
End If
Devam: Next

Set S1 = Nothing
Application.ScreenUpdating = True

MsgBox "İşleminiz tamamlanmıştır.", vbInformation
Exit Sub
Son:
Set S1 = Nothing
Application.ScreenUpdating = True
MsgBox "YILLIK GELİR sayfası dolmuştur !" & Chr(10) & "Lütfen satır ekleyiniz !", vbCritical
End Sub


önceden aylar var her sayafada ocak gelir , şubat gelir gibi 12 bunlardaki verileri bir sayfaya aktarıyor bu kod bunun gibi satış ve gelir sayfasını bir bölüm eaktarmak istiyorum

ancak sütünlarında biraz farlılıklar var oda akratılması gereker örnek nasıl olacaksa aktarıca onu rapor sayfasında ki gibi

 

[gedavet]

yeni açıklama yazdım nasıl aktarılması gerektiğini hangi sünlar hangi sütuna

hocalarım bukonuda bana yardımcı olabilirmisiniz anlaşılmayan yerleri sorarsanız açıklamaya çalışayım

yeniden anlatmaya çalışdım ekdeki örnekde

2. MESAJDAKİ KOD AKTARI YOR ANCAK HANGİ SÜTUNU HANGİ SUTUNA AKTARACAĞINI BELİRLEYEMİYORUM

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu kullanabilirsiniz.

Option Explicit
 
Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim Satır As Long, X As Long
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("RAPOR")
    Set S2 = Sheets("SATIŞ")
    Set S3 = Sheets("GELİR")
    
    S1.Select
    Range("B5:S65536").ClearContents
    Satır = 5
    
    For X = 5 To S2.Range("B65536").End(3).Row
        S1.Range("B" & Satır & ":J" & Satır).Value = S2.Range("B" & X & ":J" & X).Value
        S1.Range("K" & Satır) = S2.Range("L" & X)
        S1.Range("S" & Satır) = S2.Range("M" & X)
        Satır = Satır + 1
    Next
    
    For X = 5 To S3.Range("B65536").End(3).Row
        S1.Range("B" & Satır & ":G" & Satır).Value = S3.Range("B" & X & ":G" & X).Value
        S1.Range("L" & Satır & ":S" & Satır).Value = S3.Range("H" & X & ":O" & X).Value
        Satır = Satır + 1
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[gedavet]

korhan bey ilginiz için çok teşekkür ederim tam istediğim gibi olmuş emeğinise sağlık

ancak bir yerdede 3 sayfayı bir yere aktaracağım nasıl uyarlayacağım ve bazı yerdede 2 sayfayı bir yere nereleri değiştirmem lazım

 

[Korhan Ayhan]

Selamlar,

Mesela 3 sayfadan tek sayfaya aktarım yapacaksanız sayfa isimlerinizi aşağıdaki şekilde sabitlemeniz gerekiyor.

Set S[COLOR=red]4[/COLOR] = Sheets("DENEME")

Ayrıca X döngüsünden bir adet daha çoğaltmanız gerekiyor.

    For X = 5 To S[COLOR=red]4[/COLOR].Range("B65536").End(3).Row
        S1.Range("B" & Satır & ":G" & Satır).Value = S[COLOR=red]4[/COLOR].Range("B" & X & ":G" & X).Value
        S1.Range("L" & Satır & ":S" & Satır).Value = S[COLOR=red]4[/COLOR].Range("H" & X & ":O" & X).Value
        Satır = Satır + 1
    Next

 

[gedavet]

Ilginiz için teşekkür ederim her halde anladım deneyeceği