Makro ile hızlı ortalama aldırmak hk.

[ramazankaya89]

Herkese Merhabalar,

örnekteki dosyamda yeralan bir projem için 3 adet ürün grubum var bu ürün gruplarım için yurtiçi satışlarımın satıs tarıhlerındekı döviz kurlarına göre döviz kur ortalamasını aldırmak istiyorum yapmak istedigim dosya buyuk oldugu ıcın en hızlı sekılde sonuca ulasmam lazım

P sütununda yeralan "İÇ PİYASA" değeri için O sütunundaki tl tutarları Q sütunundaki döviz kuruna böldürerek öncelikli olarak döviz karsılıgını bır yere yazdırmadan hesaplamasını bu sonuc bazlı olarak A sütunundaki degerleri gözeterek sonuc sayfasına Toplam TL / Toplam Döviz olacak sekılde ortalama döviz kurunu yazdırmasını istiyorum.

Q sütununda olası bir insani hata olabilecegini gözeterek döviz kuru bos olsa dahi hata vermeden ıslemı sonuclandırabılırmıyız.

dosya cok buyuk oldugu ıcın makro ıle yapmam gerekıyor yardımlarınız ıcın sımdıden hepınıze cok tesekkur edıyorum.

https://s6.dosya.tc/server18/fh73tm/Dosya.xlsx.html

 

[alicimri]

AŞağıdaki kodu deneyin

Sub orta()
Application.ScreenUpdating = False
son = Sayfa1.Cells(Rows.Count, 1).End(3).Row
For i = 2 To son
If Sayfa1.Range("P" & i) = "İÇ PİYASA" Then
sat = Sayfa2.Columns(1).Find(Sayfa1.Range("A" & i)).Row
Sayfa2.Range("B" & sat) = Sayfa2.Range("B" & sat) + (Sayfa1.Range("O" & i) / Sayfa1.Range("Q" & i))
End If
Next
son1 = Sayfa2.Cells(Rows.Count, 1).End(3).Row
For e = 1 To 3
Top = Application.SumIfs(Sayfa1.Columns(15), Sayfa1.Columns(1), Sayfa2.Range("A" & e), Sayfa1.Columns(16), "İÇ PİYASA")
Sayfa2.Range("B" & e) = Top / Sayfa2.Range("B" & e)
Next
Application.ScreenUpdating = True
End Sub

 

[ramazankaya89]

hocam denedım sorunsuz calısıyor fakat atıyorum dovız kurunu yazmayı unuttugumuz zaman hata alıyor bunu yok sayarak gecıp bırde bıraz daha hızlı bır sekılde calısacak detaylar ekleyebılırmıyız suresı genel dosyamda baya zaman alıyor cok tesekkur ederım

 

[alicimri]

ADO yapılmış örneği deneyin

Sub orta()
Dim Con As Object
Dim RS As Object
Dim SH As Worksheet
Set SH = Sheets("Sonuc")
Filename = ThisWorkbook.FullName
Set Con = CreateObject("ADODB.CONNECTION")
    With Con
        .Open "Provider=Microsoft.Ace.Oledb.12.0;" & _
         "Extended Properties='Excel 12.0;" & _
         "HDR=Yes;';Data Source=" & Filename
    End With
Set RS = VBA.CreateObject("ADODB.Recordset")
        Sql = "SELECT BÖLÜM, Sum([TRY TUTAR]/[€]) AS aa, Sum([TRY TUTAR]) AS bb FROM [Bilgiler$]"
 Sql = Sql & " WHERE ((([İç-Dış]) = 'İÇ PİYASA')) GROUP BY BÖLÜM"
              RS.Open Sql, Con, 1, 3
   sat = 1
      Do While Not RS.EOF
          SH.Range("A" & sat).Value = RS("BÖLÜM")
          SH.Range("B" & sat).Value = RS("bb") / RS("aa")
          sat = sat + 1
           RS.MoveNext
       Loop
   RS.Close
  Set RS = Nothing
  Set SH = Nothing
End Sub

 

[Korhan Ayhan]

Alternatif...

Hız olarak avantaj sağlayabilir..

Option Explicit

Sub Average_Report()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim My_Array As Object, My_Data As Variant
    Dim X As Long, Currency_Amount As Double
    Dim My_Criteria As Variant, My_Key As Variant
    Dim Process_Time As Double, No As Long
   
    Application.ScreenUpdating = False
   
    Process_Time = Timer
   
    Set S1 = Sheets("Bilgiler")
    Set S2 = Sheets("Sonuc")
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
   
    S2.Cells.Clear
   
    My_Data = S1.Range("A2:Q" & S1.Cells(S1.Rows.Count, 1).End(3).Row).Value
   
    ReDim My_List(1 To UBound(My_Data), 1 To 2)
   
    For X = LBound(My_Data) To UBound(My_Data)
        If My_Data(X, 16) = "İÇ PİYASA" And My_Data(X, 17) <> "" Then
            If Not My_Array.Exists(My_Data(X, 1)) Then
                Currency_Amount = My_Data(X, 15) / My_Data(X, 17)
                My_Array.Add My_Data(X, 1), Array(My_Data(X, 15), Currency_Amount)
            Else
                Currency_Amount = My_Data(X, 15) / My_Data(X, 17)
                My_Criteria = My_Array.Item(My_Data(X, 1))
                My_Criteria(0) = My_Criteria(0) + My_Data(X, 15)
                My_Criteria(1) = My_Criteria(1) + Currency_Amount
                My_Array.Item(My_Data(X, 1)) = My_Criteria
            End If
        End If
    Next
   
    For Each My_Key In My_Array.Keys
        No = No + 1
        My_List(No, 1) = My_Key
        My_List(No, 2) = My_Array(My_Key)(0) / My_Array(My_Key)(1)
    Next
   
    S2.Range("A1:B1") = Array("BÖLÜM", "ORTALAMA KUR")
    S2.Range("A1:B1").Font.Bold = True
    S2.Range("A2").Resize(No, 2) = My_List
    S2.Range("B:B").NumberFormat = "#,##0.0000"
    S2.Range("A1").CurrentRegion.Borders.LineStyle = 1
    S2.Columns.AutoFit
   
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub

 

[ramazankaya89]

cok tesekkurler herkese emegınıze saglık sorunsuz calıstı