• DİKKAT

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

Tablonun sadeleştirilmesi

S

sezgin06

Katılım
26 Eylül 2021
Mesajlar
52
Excel Vers. ve Dili
2016 Türkçe
Merhaba;

Örnek dosyadaki ilk tabloya yapılacak işlemler giriliyor , makro yardımıyla 2 ve 3 ncü tabloda kalan ürün, miktarı ve ağırlıklı ortalama fiyatı bulunuyor.

Daha anlaşılır ve sade olması amacıyla mavi tabloyu, M sütununu da iptal ederek , verilerini elle girdiğim yeşil tablo gibi, makroda değişiklik yapmak suretiyle düzenleyebilir miyiz?
 

Ekli dosyalar

Son düzenleme:
Merhaba.

Konuya hakim değilim yeşil tabloya göre uyarlamaya çalıştım. Umarım olur.
 

Ekli dosyalar

sezgin06' Alıntı:
Ziynettin bey teşekkür ederim süper... Emeğinize desteğinize sağlık,iyi akşamlar diliyorum.
Genişletmek için tıkla ...
Tekrar merhaba,
Tabloyu detaylı incelediğimde yerleşim ve mevcut değişiminde problem yok yalnız ağırlıklı ortalama hesabında makro işlem yapmıyor, bakma imkanınız olursa sevinirim...Teşekkür ederim
 
sezgin06' Alıntı:
Tekrar merhaba,
Tabloyu detaylı incelediğimde yerleşim ve mevcut değişiminde problem yok yalnız ağırlıklı ortalama hesabında makro işlem yapmıyor, bakma imkanınız olursa sevinirim...Teşekkür ederim
Genişletmek için tıkla ...
Konunun daha anlaşılır olması adına örnek dosyayı inceleyebilirsiniz
 

Ekli dosyalar

sezgin06' Alıntı:
Konunun daha anlaşılır olması adına örnek dosyayı inceleyebilirsiniz
Genişletmek için tıkla ...
Merhaba,

Mevcut makronun işlem konusunda problemi yok, değişikliği istenen, M sütununun iptal edilerek mavi tablonun yeşil olanın şekline çevrilmesi, yani R sütununda boş olan hücrelerin satırının silinmesi. Yardımcı olursanız sevinirim, teşekkürler...
 
#5. iletideki ekli dosyanıza ait çalışma.

Kod: 
Sub test()
son = Cells(Rows.Count, 2).End(3).Row
a = Range("B1:F" & son).Value
Set dc = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To 5)
ReDim c(1 To UBound(a), 1 To 5)

For i = 2 To UBound(a)
    krt = a(i, 2)
    If Not dc.exists(krt) Then
    
        dc(krt) = dc.Count + 1
        Say = dc.Count
        b(Say, 1) = krt
        
        If a(i, 1) = "Alış" Then
            b(Say, 2) = a(i, 4)
            b(Say, 5) = CDbl(a(i, 5))
         End If
            
        If a(i, 1) = "Satış" Then
            b(Say, 3) = a(i, 4)
        End If
        
    Else
    
        Say = dc(krt)
        If a(i, 1) = "Alış" Then
            b(Say, 2) = b(Say, 2) + a(i, 4)
            b(Say, 5) = b(Say, 5) + CDbl(a(i, 5))
        End If
        
        If a(i, 1) = "Satış" Then
            b(Say, 3) = b(Say, 3) + a(i, 4)
        End If
        
    End If
    
    b(Say, 4) = b(Say, 2) - b(Say, 3)
    
Next i

For i = 1 To dc.Count
    If b(i, 4) <> 0 Then
        n = n + 1
        c(n, 1) = b(i, 1)
        c(n, 2) = b(i, 2)
        c(n, 3) = b(i, 3)
        c(n, 4) = CDbl(b(i, 4))
        c(n, 5) = CDbl(b(i, 5)) / CDbl(b(i, 2))
    End If
Next i

Range("O2:S" & Rows.Count).ClearContents
Range("O2:S" & Rows.Count).ClearFormats
[O2].Resize(n, 5).Borders.Color = rgbSilver
[S2].Resize(n).NumberFormat = "#,##0.00"
[O2].Resize(n, 5) = c

MsgBox "İşlem bitti...", vbInformation
End Sub
 
Ziynettin' Alıntı:
#5. iletideki ekli dosyanıza ait çalışma.

Kod: 
Sub test()
son = Cells(Rows.Count, 2).End(3).Row
a = Range("B1:F" & son).Value
Set dc = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To 5)
ReDim c(1 To UBound(a), 1 To 5)

For i = 2 To UBound(a)
    krt = a(i, 2)
    If Not dc.exists(krt) Then
   
        dc(krt) = dc.Count + 1
        Say = dc.Count
        b(Say, 1) = krt
       
        If a(i, 1) = "Alış" Then
            b(Say, 2) = a(i, 4)
            b(Say, 5) = CDbl(a(i, 5))
         End If
           
        If a(i, 1) = "Satış" Then
            b(Say, 3) = a(i, 4)
        End If
       
    Else
   
        Say = dc(krt)
        If a(i, 1) = "Alış" Then
            b(Say, 2) = b(Say, 2) + a(i, 4)
            b(Say, 5) = b(Say, 5) + CDbl(a(i, 5))
        End If
       
        If a(i, 1) = "Satış" Then
            b(Say, 3) = b(Say, 3) + a(i, 4)
        End If
       
    End If
   
    b(Say, 4) = b(Say, 2) - b(Say, 3)
   
Next i

For i = 1 To dc.Count
    If b(i, 4) <> 0 Then
        n = n + 1
        c(n, 1) = b(i, 1)
        c(n, 2) = b(i, 2)
        c(n, 3) = b(i, 3)
        c(n, 4) = CDbl(b(i, 4))
        c(n, 5) = CDbl(b(i, 5)) / CDbl(b(i, 2))
    End If
Next i

Range("O2:S" & Rows.Count).ClearContents
Range("O2:S" & Rows.Count).ClearFormats
[O2].Resize(n, 5).Borders.Color = rgbSilver
[S2].Resize(n).NumberFormat = "#,##0.00"
[O2].Resize(n, 5) = c

MsgBox "İşlem bitti...", vbInformation
End Sub
Genişletmek için tıkla ...
Ziynettin bey öncelikle ilginize teşekkür ederim,bu makroda da ağırlıklı ortalama hesabında hatalı sonuç veriyor. Farklı zaman,miktar ve fiyattan alınan ve satılan aynı ürün girildiğinde.Sizin makroyu uyarladım şimdiki dosyaya,#5.iletideki dosyaya aynı ürün hareketlerini aktardığımızda fark edeceksiniz.
 

Ekli dosyalar

Merhaba,

Yürüyen ağırlıklı ortalama istiyorsunuz galiba.
Sayın Ziynettin'in affına sığınarak gerekli revizeyi yaptım.
C++: 
Sub test()
son = Cells(Rows.Count, 2).End(3).Row
a = Range("B1:F" & son).Value
Set dc = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To 5)
ReDim c(1 To UBound(a), 1 To 5)

For i = 2 To UBound(a)
    krt = a(i, 2)
    If Not dc.exists(krt) Then
   
        dc(krt) = dc.Count + 1
        Say = dc.Count
        b(Say, 1) = krt
       
        If a(i, 1) = "Alış" Then
            b(Say, 2) = a(i, 4)
            b(Say, 5) = CDbl(a(i, 5))
         End If
           
        If a(i, 1) = "Satış" Then
            b(Say, 3) = a(i, 4)
        End If
       
    Else
   
        Say = dc(krt)
        If a(i, 1) = "Alış" Then
            b(Say, 2) = b(Say, 2) + a(i, 4)
            b(Say, 5) = b(Say, 5) + CDbl(a(i, 5))
        End If
       
        If a(i, 1) = "Satış" Then
            b(Say, 5) = b(Say, 5) - (b(Say, 5) / b(Say, 4) * a(i, 4))      'Devir Tutarı - (Devir Tutarı / Devir Miktarı * Satış Miktarı)
            b(Say, 3) = b(Say, 3) + a(i, 4)
           
        End If
       
    End If
   
    b(Say, 4) = b(Say, 2) - b(Say, 3)
   
Next i

For i = 1 To dc.Count
    If b(i, 4) <> 0 Then
        n = n + 1
        c(n, 1) = b(i, 1)
        c(n, 2) = b(i, 2)
        c(n, 3) = b(i, 3)
        c(n, 4) = CDbl(b(i, 4))
        c(n, 5) = CDbl(b(i, 5)) / CDbl(b(i, 4))      'Devir Tutarı / Devir Miktarı
    End If
Next i

Range("O2:S" & Rows.Count).ClearContents
Range("O2:S" & Rows.Count).ClearFormats
[O2].Resize(n, 5).Borders.Color = rgbSilver
[S2].Resize(n).NumberFormat = "#,##0.00"
[O2].Resize(n, 5) = c

MsgBox "İşlem bitti...", vbInformation
End Sub
 
Son düzenleme:
dost' Alıntı:
Merhaba,

Yürüyen ağırlıklı ortalama istiyorsunuz galiba.
Sayın Ziynettin'in affına sığınarak gerekli revizeyi yaptım.
C++: 
Sub test()
son = Cells(Rows.Count, 2).End(3).Row
a = Range("B1:F" & son).Value
Set dc = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To 5)
ReDim c(1 To UBound(a), 1 To 5)

For i = 2 To UBound(a)
    krt = a(i, 2)
    If Not dc.exists(krt) Then
  
        dc(krt) = dc.Count + 1
        Say = dc.Count
        b(Say, 1) = krt
      
        If a(i, 1) = "Alış" Then
            b(Say, 2) = a(i, 4)
            b(Say, 5) = CDbl(a(i, 5))
         End If
          
        If a(i, 1) = "Satış" Then
            b(Say, 3) = a(i, 4)
        End If
      
    Else
  
        Say = dc(krt)
        If a(i, 1) = "Alış" Then
            b(Say, 2) = b(Say, 2) + a(i, 4)
            b(Say, 5) = b(Say, 5) + CDbl(a(i, 5))
        End If
      
        If a(i, 1) = "Satış" Then
            b(Say, 5) = b(Say, 5) - (b(Say, 5) / b(Say, 4) * a(i, 4))      'Devir Tutarı - (Devir Tutarı / Devir Miktarı * Satış Miktarı)
            b(Say, 3) = b(Say, 3) + a(i, 4)
          
        End If
      
    End If
  
    b(Say, 4) = b(Say, 2) - b(Say, 3)
  
Next i

For i = 1 To dc.Count
    If b(i, 4) <> 0 Then
        n = n + 1
        c(n, 1) = b(i, 1)
        c(n, 2) = b(i, 2)
        c(n, 3) = b(i, 3)
        c(n, 4) = CDbl(b(i, 4))
        c(n, 5) = CDbl(b(i, 5)) / CDbl(b(i, 4))      'Devir Tutarı / Devir Miktarı
    End If
Next i

Range("O2:S" & Rows.Count).ClearContents
Range("O2:S" & Rows.Count).ClearFormats
[O2].Resize(n, 5).Borders.Color = rgbSilver
[S2].Resize(n).NumberFormat = "#,##0.00"
[O2].Resize(n, 5) = c

MsgBox "İşlem bitti...", vbInformation
End Sub
Genişletmek için tıkla ...
Sayın dost teşekkür ederim sorunun cevabı tam da bu makro, Sayın Ziynettin'in de emeği çok bu çalışmada.Galiba sorunu ben tam anlatamadım çözüme ulaşılma sürecinde. Tekrar her ikinize de çok teşekkür ederim , iyi çalışmalar...
 
Merhaba,

İlk önce işinizin çözüldüğüne sevindim.

Zaten ufak bir değişiklik dışında ben fazla bir şey yapmadım.

Aslında "Ağırlıklı ortalma" deyince Sayın Ziynettin'in yazdığı kod doğru.
Ancak "Hareketli ağırlıklı ortalma" deyince iş biraz değişiyor.

Mantığı kurup kodu yazan Sayın Ziynettin. Onun emeğine teşekkür ederiz.

Kolay gelsin.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst