30 Sekmelik Bir Excelde Tarihle Birlikte İcmal Oluşturma

[td877]

Merhaba,

Ayın 1'inden, 31'ine kadar tuttuğumuz puantaj tablomuzu ay sonunda toplu görebilmek adına birleştirmek istiyorum.

Örnek bir dosyayı ekte iletiyorum.

Yardımlarınız için şimdiden teşekkür ederim.

Ornek_Dosya__Excel_Web__29.01.2021.xlsx dosyasını indir - download

Ornek_Dosya__Excel_Web__29.01.2021.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

www.dosya.tc

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Icmale_Aktar()
    Dim S1 As Worksheet, Sh As Worksheet, Satir As Long, Son As Long, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("İcmal")
    
    S1.Range("B3:D" & S1.Rows.Count).Clear
    
    Satir = 3
    
    For Each Sh In ThisWorkbook.Worksheets
        If Sh.Name <> S1.Name Then
            Son = Sh.Cells(Sh.Rows.Count, "C").End(3).Row
            If Son > 3 Then
                S1.Range("B" & Satir).Resize(Son - 3, 1).Value = Sh.Name
                S1.Range("C" & Satir).Resize(Son - 3, 2).Value = Sh.Range("C4:D" & Son).Value
                Satir = S1.Cells(S1.Rows.Count, "C").End(3).Row + 1
            End If
        End If
    Next
    
    S1.Range("B:D").EntireColumn.AutoFit
    S1.Range("B3:D" & Satir - 1).Borders.LineStyle = 1
    S1.Select
    
    Set S1 = Nothing
    
    MsgBox "Aktarım işlemi tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub