6 farklı sayfadaki bilgileri 1 sayfada toplamak

[numan şamil]

Merhaba
Ders sayısı, ana dosyadaki diziliş sırası ve yazılışları aynı olmalıdır
NO ADI-SOYADI TÜRKÇE MATEMATİK DİN FEN İNKILAP İNGİLİZCE
Ayrıca veri alınacak dosyaların başlık yazılar bilhassa (-) den önce dersin adı olmalı
TÜRKÇE - DENEME SINAVI SONUÇLARI (MAZERET ORTAK SINAV)gibi
satırlarıda bulundukları hücreleride değişiklik göstermemeli

 

[hsnorh]

Tamamdır hocam, aynı format olacak, sadece daha fazla kişi ve farklı isim ve numaralı öğrenciler olacak. Hücrelerin yerleri ve içerdiği bilgi türlerine dikkat edilecek.

 

[hsnorh]

Merhaba
ekli dosyayı dener misiniz
numarayı baz alıyor
öğrenci sayısını istendiğiniz kadar azaltıp artırabilirsiniz
ortamalar ikinci satıra alındı ve makro ile hesaplattırıldı.

Denemeleri yaptım hocam, şimdilik bir sıkıntı görülmüyor. Ellerinize sağlık. :hihoho:

Benim de bu tip kodlar hazırlayabilmem için kullandığınız özelliklere yönlendirme verebilirseniz iyi olur.

mesela:

Sub aktar()
 Dim Klasör As Object, Veri_Dosyası As Workbook, SR As Worksheet, Dosya_Yolu As String
    Dim Satır As Long, Dosya As Object, Kaynak_Dosya As Object, SAYFA, SAYFA1 As Worksheet

    On Error GoTo son
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
    If Klasör Is Nothing Then
        MsgBox "Klasör seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
        Exit Sub
    End If
    Range("C4:H" & Rows.Count).ClearContents
    Range("C2:H2").ClearContents
    Application.ScreenUpdating = False
    Set Veri_Dosyası = ThisWorkbook
    Set SR = Veri_Dosyası.Sheets("TOPLUSONUC")
    Dosya_Yolu = Klasör.Items.Item.Path
    If CreateObject("Scripting.FileSystemObject").getfolder(Dosya_Yolu).Files.Count = 0 Then GoTo son
    For Each Dosya In CreateObject("Scripting.FileSystemObject").getfolder(Dosya_Yolu).Files
        If Dosya.Name <> Veri_Dosyası.Name Then
            Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)

burada klasör seçimini yaptırdıktan sonra, klasör seçilmedi ise işlemi iptal ettirdik galiba. Bu özelliğin adı nedir excel makro dünyasında? Ne diye arattırıp çalışmalıyım bu konuya?

burada mesela

 Set SAYFA = Kaynak_Dosya '.Sheets("tüketimler")
 Satır = 4
 satır1 = 4
 satır2 = 4
 satır3 = 4
 satır4 = 4
 satır5 = 4
            For Each SAYFA In Kaynak_Dosya.Worksheets
            
       For k = 5 To SAYFA.[A65536].End(3).Row  '.Range("A2:A" & Rows.Count).End(3).Row
      
       'SAYFA.Range("K" & k) = SAYFA.Range("B" & k) & " " & SAYFA.Range("A" & k)
        SAYFA.Range("K2") = Split(SAYFA.Range("A2"), "-")(0)
        SAYFA.Range("K2") = Replace(SAYFA.Range("K2"), " ", "")
        '****************************************************************
       If SR.Range("C3") = SAYFA.Range("K2") Then
       SR.Range("AA" & Satır) = SAYFA.Range("C" & k)
       SR.Range("AB" & Satır) = SAYFA.Range("F" & k)
       Satır = Satır + 1
        End If
       '****************************************************************
       If SR.Range("D3") = SAYFA.Range("K2") Then
        SR.Range("AC" & satır1) = SAYFA.Range("C" & k)
       SR.Range("AD" & satır1) = SAYFA.Range("F" & k)
       satır1 = satır1 + 1
       End If
       '******************************************************
       If SR.Range("E3") = SAYFA.Range("K2") Then
        SR.Range("AE" & satır2) = SAYFA.Range("C" & k)
       SR.Range("AF" & satır2) = SAYFA.Range("F" & k)
       satır2 = satır2 + 1
       End If
       '****************************************************************
       If SR.Range("F3") = SAYFA.Range("K2") Then
        SR.Range("AG" & satır3) = SAYFA.Range("C" & k)
       SR.Range("AH" & satır3) = SAYFA.Range("F" & k)
       satır3 = satır3 + 1
       End If
       '******************************************************
        If SR.Range("G3") = SAYFA.Range("K2") Then
        SR.Range("AI" & satır4) = SAYFA.Range("C" & k)
       SR.Range("AJ" & satır4) = SAYFA.Range("F" & k)
       satır4 = satır4 + 1
       End If
       '****************************************************************
       If SR.Range("H3") = SAYFA.Range("K2") Then
        SR.Range("AK" & satır5) = SAYFA.Range("C" & k)
       SR.Range("AL" & satır5) = SAYFA.Range("F" & k)
       satır5 = satır5 + 1
       End If
       '*****************************************************
       SAYFA.Range("K1:K" & Rows.Count).ClearContents
            
            Next k
            Next
            Kaynak_Dosya.Close True
        End If

set diyerek bir değer oluşturduk galiba sonra if kullanarak kontrol edip bir artırarak bir şeyler yaptık galiba?

yani atıyorum bu dosyayı oluşturabilmek için şu, şu ve şu özellikleri bilmen lazım gibi bir yol gösterirseniz müteşekkir olurum. Tekrardan teşekkürler ellerinize sağlık...

 

[numan şamil]

Merhaba
Kodların işe yaradığına sevindim
Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
If Klasör Is Nothing Then
MsgBox "Klasör seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
Exit Sub
End If
Bu bölüm dediğiniz gibi bir klasör seçilmediği için makro sonlandırıyor
Set SAYFA = Kaynak_Dosya
Veri aktarılacak dosyalara SAYFA ismini tanımladık
Satır = 4
Verileri yazdırmaya 4. Satırdan itibaren başladık
Satır=Satır+1
Verileri birer satır arttırarak yazdırdık
For k = 5 To SAYFA.[A65536].End(3).Row
For döngüsü kurduk
Yani veri alınacak dosyalarda ki sayfalarda satır 5 den A sütunundaki enson veriye kadar döngünün
Çalışmasını sağladık
Benim önerim bu formu takip etmeniz. Altın üye olup eğitim amaçlı bazı görselleri elde etmeniz
Ayrıca daha basit kodlarla çalışmaya başlarsanız
İyi olur
İyi Çalışmalar

 

[hsnorh]

Tekrardan teşekkürler. Size de iyi çalışmalar.

 

[keremonder]

Merhaba,

Aşağıdaki formülü Toplu Sonuç sayfasındaki B4 hücresine yapıştırıp sürükleyebilirsiniz.

=TOPLA.ÇARPIM(--(PARÇAAL($A4;MBUL(" ";$A4)+1;UZUNLUK($A4)-MBUL(" ";$A4)+1)=DOLAYLI(B$3&"!$A$5:$A$28")) * (PARÇAAL($A4;1;MBUL(" ";$A4)-1)=DOLAYLI(B$3&"!$b$5:$b$28")) * (DOLAYLI(B$3&"!$f$5:$f$28")))

 

[hsnorh]

Merhaba,

Aşağıdaki formülü Toplu Sonuç sayfasındaki B4 hücresine yapıştırıp sürükleyebilirsiniz.

=TOPLA.ÇARPIM(--(PARÇAAL($A4;MBUL(" ";$A4)+1;UZUNLUK($A4)-MBUL(" ";$A4)+1)=DOLAYLI(B$3&"!$A$5:$A$28")) * (PARÇAAL($A4;1;MBUL(" ";$A4)-1)=DOLAYLI(B$3&"!$b$5:$b$28")) * (DOLAYLI(B$3&"!$f$5:$f$28")))

Merhaba Kerem bey, dosyalar aynı çalışma kitabında iken sizin verdiğiniz kod mükemmel bir şekilde çalıştı. Artık duruma göre kullanılabilecek 2 farklı yöntem mevcut. Teşekkürler.:icelim: