sayfaları yan yana birleştirme

[esdrym]

Merhabalar
Her seferinde manual hazırlamak zorunda olduğum bir dosya bulunuyor. Bana yardımcı olur musunuz?
Dosyamda birkaç tane çalışma sayfamı birleştirip yan yana yazdırmak istiyorum. Amacım haftalar bazında müşterileri durumunu karşılaştırmak. Ekte örnek dosyamı ekliyorum. İlk üç sayfa haftalık olarak hazırlanıyor. Ben özet sayfasını otomatik oluşturmak istiyorum. Aynı müşterileri aynı satıra yazmasını o hafta yok ise o satırı boş bırakmak istiyorum.
Teşekkürler.

 

[Ömer BARAN]

Merhaba.

Alt taraftan ÖZET sayfasının adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin.
Açılan VBA ekranında, sağ taraftaki boş alana aşağıdaki kod'u yapıştırın ve
VBA ekranında iken F5 tuşuna basarak kod'u çalıştırın.
.

[FONT="Arial Narrow"]Sub ÖZET()
Set oz = Sheets("özet"): oz.Cells.ClearContents
oz.Cells(2, 1) = "Adı": oz.Cells(2, 2) = "Borç": oz.Cells(2, 3) = "Alacak"
oz.Cells(2, 4) = "Bakiye": oz.Cells(2, 5) = "Çek"
For Each Worksheet In ThisWorkbook.Worksheets
    If Worksheet.Name = "özet" Then GoTo 10
    Worksheet.Activate: Worksheet.Range("A2:A" & Worksheet.[A65536].End(3).Row).Copy _
    oz.Cells(oz.[A65536].End(3).Row + 1, 1)
10: Next
oz.Range("A2:A" & oz.[A65536].End(3).Row).RemoveDuplicates Columns:=1, Header:=xlNo
oz.Activate: oz.Range("A3:A" & oz.[A65536].End(3).Row).Sort [A2], xlAscending
For Each Worksheet In ThisWorkbook.Worksheets
    If Worksheet.Name = "özet" Then GoTo 20
    sut = oz.[IV2].End(1).Column + 2
oz.Range("B2:E2").Copy oz.Cells(2, oz.[IV2].End(1).Column + 2)
Worksheet.Activate: oz.Cells(1, sut) = ActiveSheet.Name: oz.Range(Cells(1, sut), Cells(1, sut + 3)).Merge
For sat = 2 To ActiveSheet.[A65536].End(3).Row
    satır = WorksheetFunction.Match(ActiveSheet.Cells(sat, 1), oz.Range("A:A"), 0)
    Worksheet.Range("B" & sat & ":E" & sat).Copy oz.Cells(satır, sut)
Next
20: Next: oz.Columns("B:F").Delete Shift:=xlToLeft: oz.Activate
oz.Range(1 & ":" & 1).HorizontalAlignment = xlCenter: MsgBox "İŞLEM TAMAM"
End Sub[/FONT]

 

[esdrym]

Çok teşekkür ederim beni büyük dertten kurtardınız
Kolay gelsin...

 

[kayserciyes]

üsdat banada benzeri lazım ama ben yapamadım bunu
F5 e basıyorum makro adı soruyor
A1:Z60 Arasını
Tek bir çalışma sayfasında birleştirmek istiyorum
A1 lere sayfaların adı yazılarak birleşen sayfada sayfa adları ne ise bilinmesi
yardımcı olursanız sevinirim

 

[Korhan Ayhan]

Örnek dosyanızı ve görmek istediğiniz sonucu paylaşırsanız yardım almanız kolaylaşacaktır.

 

[kayserciyes]

Korhan hocam ekte örnek doya ekledim
uzun zamandır manuel yapıyordum bir çözüm bulur yardımcı olursanız sevinirim
şimdiden teşekkürler

 

[Korhan Ayhan]

Dosyanızda birleşime dahil olmayacak sayfalar var mı?

Kodu deneyiniz.

Option Explicit

Sub Dersleri_Birlestir()
    Dim S1 As Worksheet, Sayfa As Worksheet, Son_Sutun As Integer, Hedef_Sutun As Integer
  
    Application.ScreenUpdating = 0
  
    Set S1 = Sheets("Birlesim")
  
    S1.Range("D:XFD").Clear
  
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> S1.Name Then
            Son_Sutun = Sayfa.Cells.Find(What:="*", After:=Sayfa.Range("A1"), _
            SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
            Hedef_Sutun = S1.Cells.Find(What:="*", After:=S1.Range("A1"), _
            SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
            Sayfa.Range("D1").Resize(Sayfa.Rows.Count, Son_Sutun - 3).Copy S1.Cells(1, Hedef_Sutun + 1)
            S1.Cells(3, Hedef_Sutun + 1).Resize(1, Son_Sutun - 3) = Left(Sayfa.Name, 3)
        End If
    Next
  
    S1.Select
  
    Set S1 = Nothing

    Application.ScreenUpdating = 1
  
    MsgBox "Dersler birleştirilmiştir.", vbInformation
End Sub

 

[kayserciyes]

Üstad Eline sağlık

Dosyanızda birleşime dahil olmayacak sayfalar var mı? HAYIR YOK

Örnek dosyada sorun yok ana dosyada
1004 hatası veriyor
Sayfa.Range("D1").Resize(Sayfa.Rows.Count, Son_Sutun - 3).Copy S1.Cells(1, Hedef_Sutun + 1)

bu kısmı sarı gösteriyor
hiç birşey yapmadan uyarıları kapatınca yine de çalışıyor ama
dosya yada sayfa adları ile mi ilgili bilemedim

 

[Korhan Ayhan]

Hata veren satırda mouse ile Son_Sutun ve Hedef_Sutun üzerine gelip bekleyin. Size aldığı değerleri gösterecektir.

Bunlarda sorun olabilir.

 

[kayserciyes]

Eyvallah Teşekkür ederim Elinize sağlık