Tüm Sayfalardaki verileri bir sayfada toplamak

[unur]

Günaydın arkadaşlar.
16.mesajımı soruma çözüm bulamadım, yardımcı olacak arkadaşlara şimdiden teşekkürler.

 

[Korhan Ayhan]

Merhaba,

Sayfalardaki bölümlerin satır sayısı sabit midir? Değilse satırlara ayrıştırıcı eklemeler yapmak gerekecektir.

 

[unur]

Korhan Bey satırlar sabit değil, personelin çokluğu yada azlığa göre değişkenlik gösterebilir. Kodlardan hiç anlamıyorum, belki saçma bir fikirdir şimdi aklıma geldi, çift çizgi kullanılabilir mi?

 

[Korhan Ayhan]

Sabit değilse tablonuza bir sütun daha eklemek daha mantıklı olacaktır.

Eklenecek bu sütuna "YILLIK İZİN-İSTİRAHAT-ŞEHİR DIŞI-HASTANE-GÜNLÜK İZİN" gibi bilgilerin yazılması çözümü kolaylaştıracaktır.

Bahsettiğim şekilde düzenlediğim örnk dosyayı inceleyiniz. "I" ve "J" sütunları yardımcı sütun olarak kullanılmıştır. Dilerseniz gizleyebilirsiniz.

GENEL sayfasında her kriter için 50 adet boş satır oluşturdum. Bu size yeterli gelmiyorsa gizli satırları açıp arttırabilirsiniz.

 

[unur]

Korhan Bey emeklerinize sağlık, tam istediğim gibi.
Dosyayı bir ortak alana çalışma kitabını paylaştır şeklinde kayıt yapıp her sayfanın yoklamasını farklı arkadaşlarımız dolduracaktı. Ancak çalışma kitabını paylaştırdığımızda kodların çalışmayacağını hesaba katamadık cahilliğimizden.
Bu dosyadaki her bir sayfanın farklı bir çalışma kitabı şeklinde yapsak ve verileri bu çalışma kitaplarında alma şansımız olur mu acaba?

 

[Korhan Ayhan]

Dosyalarınızı bahsettiğiniz şekilde ayırıp klasöre kayıt edin.

"GENEL" isimli sayfanızın olduğu dosyaya aşağıdaki kodu uygulayıp çalıştırın.

Option Explicit

Dim Klasor As Object, K1 As Workbook, S1 As Worksheet, S2 As Worksheet, Son As Long, X As Long
Dim Bul As Range, Adres As String, Zaman As Double, Dosya As String, Hedef_Kitap As Object

Sub VERİLERİ_GÜNCELLE()
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz !", 1)
    If Klasor Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Liste (Klasor.Items.Item.Path)
    
    S1.Range("A:E").EntireColumn.AutoFit
    
    Set Klasor = Nothing
    Set Bul = Nothing
    Set K1 = Nothing
    Set S1 = Nothing
    Set S2 = Nothing

    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.000") & " Saniye", vbInformation
End Sub

Private Sub Liste(Yol As String)
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("GENEL")
    
    Zaman = Timer
    
    S1.Cells.EntireRow.Hidden = False
    
    S1.Range("A15:H64").ClearContents
    S1.Range("A67:H116").ClearContents
    S1.Range("A119:H168").ClearContents
    S1.Range("A171:H220").ClearContents
    S1.Range("A223:H272").ClearContents
    
    Dosya = Dir(Yol & "\*.xls*")
    
    While Dosya <> ""
        Set Hedef_Kitap = Workbooks.Open(Yol & "\" & Dosya, False, False)
        DoEvents
        
        Set S2 = ActiveSheet
        
        S2.Range("J:J").ClearContents
        
        Son = S2.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For X = 13 To Son
            If S2.Cells(X, "A") <> "" And IsNumeric(S2.Cells(X, "A")) Then
                If S2.Cells(X, "J") = "" Then
                    Set Bul = S1.Range("I:I").Find(S2.Cells(X, "I"), , xlValues, xlWhole)
                    If Not Bul Is Nothing Then
                        Adres = Bul.Address
                        Do
                            If S1.Cells(Bul.Row, "A") = "" Then
                                If S1.Cells(Bul.Row - 1, "A") = "S.NU" Then
                                    S1.Cells(Bul.Row, "A") = 1
                                Else
                                    S1.Cells(Bul.Row, "A") = S1.Cells(Bul.Row - 1, "A") + 1
                                End If
                                    
                                S1.Range("B" & Bul.Row & ":H" & Bul.Row).Value = S2.Range("B" & X & ":H" & X).Value
                                S2.Cells(X, "J") = "Aktarıldı"
                                Exit Do
                            End If
                            
                            Set Bul = S1.Range("I:I").FindNext(Bul)
                        Loop While Not Bul Is Nothing And Bul.Address <> Adres
                    End If
                End If
            End If
        Next
        
        Hedef_Kitap.Close 0
        Dosya = Dir
    Wend

    Son = S1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For X = 13 To Son
        If S1.Cells(X, "A") = "" And S1.Cells(X, "I") <> "" Then
            S1.Rows(X).Hidden = True
        End If
    Next
End Sub

 

[unur]

Korhan Bey, bilginize sağlık, Allah razı olsun.Tam istediğim gibi bir çalışma oldu.