• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Topla Aktar, ortalamasını al

T

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,181
Excel Vers. ve Dili
Ofis 2019 Türkçe
Kod: 
Sub Arsiv_Cikis_duzenleme()
Dim sat As Long, z As Object, myarr(), list(), a As Long
Dim i As Long, deg As String, baslangic As Date, n As Long
sat = Sheets("Arsiv").Cells(1000000, "A").End(xlUp).Row
Application.ScreenUpdating = False
Sheets("ORANLAMA").Range("A2:J1000000").ClearContents
If sat < 1 Then Exit Sub
baslangic = Now
list = Sheets("Arsiv").Range("A2:J" & sat).Value
Set z = CreateObject("Scripting.Dictionary")
ReDim myarr(1 To 10, 1 To sat)
For i = 1 To UBound(list, 1)
    deg = list(i, 3) & "-" & list(i, 4)
    If Not z.Exists(deg) Then
        n = n + 1
        z.Add deg, n
        myarr(1, n) = list(i, 1)
        myarr(2, n) = list(i, 2)
        myarr(3, n) = list(i, 3)
        myarr(4, n) = list(i, 4)
   End If
    myarr(5, z.Item(deg)) = myarr(5, z.Item(deg)) + list(i, 5)
    myarr(6, z.Item(deg)) = myarr(6, z.Item(deg)) + list(i, 6)
    myarr(7, z.Item(deg)) = myarr(7, z.Item(deg)) + list(i, 7)
Next i
Set z = Nothing
Sheets("ORANLAMA").Select
sat = Sheets("ORANLAMA").Range("a" & Rows.Count).End(3).Row + 1
ReDim Preserve myarr(1 To 10, 1 To n)
Cells(sat, 1).Resize(n, 10) = Application.Transpose(myarr)
Erase myarr
Tarihduzenle
'Arsive_aktar
Application.ScreenUpdating = True
MsgBox "Süre : " & Format(Now - baslangic, "hh:mm:ss") & vbLf & _
"ORANLAMA ORANLAMA Sayfasına gönderilmek üzere Tarih ve Malzeme Kodu bazında düzenlendi." & vbLf & "Tahsin ANARAT - TOMSON", vbOKOnly + vbInformation
End Sub

Sub Tarihduzenle()
    Sheets("ORANLAMA").Select
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 4), TrailingMinusNumbers:=True
    Range("A2").Select
End Sub

kodları ile Arsiv sayfasının C ve D sutunu aynı olanların E,F.. sutunlarını toplayarak ORANLAMA sayfasına aktarıyorum. Buraya kadar tamam.
Bu toplamların oluştuğu Arşiv sayfasında kaç satır varsa toplamın bu sayıya bölünerek ortalamasın yazmasını istiyorum.
Ekli örnek dosyada 17-2 KURS 1 in EĞİTMEN2 toplamı 6 satırdan oluşan 22,12 nin 6 tıya bölünerek 3,69 sonucunu göstermesi gerekiyor.
Destek verecek hocalarıma şimdiden teşekkür ederim.
 

Ekli dosyalar

Kod: 
Sub Arsiv_Cikis_duzenleme()
    Dim sat As Long, z As Object, myarr(), list(), a As Long
    Dim i As Long, deg As String, baslangic As Date, n As Long
    sat = Sheets("Arsiv").Cells(1000000, "A").End(xlUp).Row
    Application.ScreenUpdating = False
    Sheets("ORANLAMA").Range("A2:J1000000").ClearContents
    If sat < 1 Then Exit Sub
    baslangic = Now
    list = Sheets("Arsiv").Range("A2:J" & sat).Value
    Set z = CreateObject("Scripting.Dictionary")
    ReDim myarr(1 To 10, 1 To sat)
    For i = 1 To UBound(list, 1)
        If list(i, 1) <> "" Then
            deg = list(i, 3) & "-" & list(i, 4)
            If Not z.Exists(deg) Then
                n = n + 1
                z.Add deg, n
                myarr(1, n) = list(i, 1)
                myarr(2, n) = list(i, 2)
                myarr(3, n) = list(i, 3)
                myarr(4, n) = list(i, 4)
            End If
            myarr(5, z.Item(deg)) = myarr(5, z.Item(deg)) + list(i, 5)
            myarr(6, z.Item(deg)) = myarr(6, z.Item(deg)) + list(i, 6)
            myarr(7, z.Item(deg)) = myarr(7, z.Item(deg)) + list(i, 7)
            myarr(10, z.Item(deg)) = myarr(10, z.Item(deg)) + 1
        End If
    Next i
    Set z = Nothing
    Sheets("ORANLAMA").Select
    sat = Sheets("ORANLAMA").Range("a" & Rows.Count).End(3).Row + 1
    ReDim Preserve myarr(1 To 10, 1 To n)
    Cells(sat, 1).Resize(n, 10) = Application.Transpose(myarr)
    Erase myarr
    tarihDuzenleOrtalamaBul
    'Arsive_aktar
    Application.ScreenUpdating = True
    MsgBox "Süre : " & Format(Now - baslangic, "hh:mm:ss") & vbLf & _
                                                           "ORANLAMA ORANLAMA Sayfasına gönderilmek üzere Tarih ve Malzeme Kodu bazında düzenlendi." & vbLf & "Tahsin ANARAT - TOMSON", vbOKOnly + vbInformation
End Sub

Sub tarihDuzenleOrtalamaBul()
    
    Sheets("ORANLAMA").Select
    sat = Range("a" & Rows.Count).End(3).Row
    
    Range("A2:A" & sat).TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _
        FieldInfo:=Array(1, 4)
    
    With Range("J2:J" & sat)
        .Copy
        .Offset(, -5).Resize(, 3).PasteSpecial xlPasteValues, xlPasteSpecialOperationDivide
        .ClearContents
    End With

End Sub
 
Sn. @veyselemre hocam, sizi tekrar rahatsız ediyorum bağışlayın,
iki tarih aralığına göre verileri aktarmak istiyorum, ORANLAMA sayfasının L1 hücresinde başlangıç tarihi, M1 hücresinde bitiş tarihi olacak, bu iki tarih aralığını Arşiv sayfasının A sutunundaki tarihlere göre aktarmasını istiyorum. Kodda nasıl bir değişiklik yapmalıyım. Teşekkür ederim.
 
Kod: 
Sub Arsiv_Cikis_duzenleme()
    Dim sat As Long, z As Object, myarr(), list(), a As Long
    Dim i As Long, deg As String, baslangic As Date, n As Long
    Dim basTar As Date, bitTar As Date
    
    Application.ScreenUpdating = False
    
    With Sheets("Arsiv")
        sat = .Cells(1000000, "A").End(xlUp).Row
        If sat < 1 Then Exit Sub
        baslangic = Now
        list = .Range("A2:J" & sat).Value
    End With
    
    With Sheets("ORANLAMA")
        .Range("A2:J1000000").ClearContents
        basTar = DateSerial(2000, 1, 1)
        bitTar = DateSerial(2099, 12, 31)
        If IsDate(.Range("L1").Value) Then basTar = .Range("L1").Value
        If IsDate(.Range("M1").Value) Then bitTar = .Range("M1").Value
    End With
    
    Set z = CreateObject("Scripting.Dictionary")
    
    ReDim myarr(1 To 10, 1 To sat)
    
    For i = 1 To UBound(list, 1)
        If list(i, 1) <> "" And list(i, 1) >= basTar And list(i, 1) <= bitTar Then
            deg = list(i, 3) & "-" & list(i, 4)
            If Not z.Exists(deg) Then
                n = n + 1
                z.Add deg, n
                myarr(1, n) = list(i, 1)
                myarr(2, n) = list(i, 2)
                myarr(3, n) = list(i, 3)
                myarr(4, n) = list(i, 4)
            End If
            myarr(5, z.Item(deg)) = myarr(5, z.Item(deg)) + list(i, 5)
            myarr(6, z.Item(deg)) = myarr(6, z.Item(deg)) + list(i, 6)
            myarr(7, z.Item(deg)) = myarr(7, z.Item(deg)) + list(i, 7)
            myarr(10, z.Item(deg)) = myarr(10, z.Item(deg)) + 1
        End If
    Next i
    
    Set z = Nothing
    
    If n > 0 Then
        Sheets("ORANLAMA").Select
        ReDim Preserve myarr(1 To 10, 1 To n)
        Cells(2, 1).Resize(n, 10) = Application.Transpose(myarr)
        Erase myarr
        tarihDuzenleOrtalamaBul
    End If
    'Arsive_aktar
    Application.ScreenUpdating = True
    MsgBox "Süre : " & Format(Now - baslangic, "hh:mm:ss") & vbLf & _
                                                           "ORANLAMA ORANLAMA Sayfasına gönderilmek üzere Tarih ve Malzeme Kodu bazında düzenlendi." & vbLf & "Tahsin ANARAT - TOMSON", vbOKOnly + vbInformation
End Sub

Sub tarihDuzenleOrtalamaBul()
    
    Sheets("ORANLAMA").Select
    sat = Range("a" & Rows.Count).End(3).Row
    
    Range("A2:A" & sat).TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _
        FieldInfo:=Array(1, 4)
    
    With Range("J2:J" & sat)
        .Copy
        .Offset(, -5).Resize(, 3).PasteSpecial xlPasteValues, xlPasteSpecialOperationDivide
        .ClearContents
    End With

End Sub
 
Son düzenleme:
Sn. @veyselemre Hocam,
ReDim myarr(1 To 10, 1 To sat)
satırında hata alıyorum.
 

Ekli dosyalar

  • Hatasatırı.JPG
    Hatasatırı.JPG
    81 KB · Görüntüleme: 1
Son düzenlemeden sonra CTRL Z yapmışım galiba.. Yukarıdaki kodu düzenledim.
 
Sn. @veyselemre Hocam çok teşekkür ediyorum, Elinize sağlık. Tam istediğim şekilde oldu. Allah Razı olsun.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst