matematiksel bir soru

[modoste]

ekli dosyamda sorumu ilettim
makro ile çözümde olabilir. çözülmesi gereken hücrelerdeki (I6....I14 arası hücreler) değerler devamlı değişebilecek birşey gibi geldi tek bir çözümü olmayan bir soru gibi

 

[muhasebeciyiz]

Mantık şu:

Toplam 243 sabit kalacak.
Kalem-5 değeri 32’den 34,5’e çıkınca toplamda +2,5 artış oluyor.
Bu yüzden diğer kalemlerden toplam 2,5 azaltmanız yeterli.
Ama azaltılan kalem(ler)in yeni oranı, kendi alt sınır–üst sınır aralığında kalmalı.
Sizin tabloda bunun tek bir çözümü yok; birden fazla uygun çözüm var.

En basit uygun çözüm:

Sadece Kalem-9’u 30 → 27,5 yapın
Diğerlerini aynı bırakın

Yeni değerler:
Kalem-1: 10
Kalem-2: 12
Kalem-3: 18
Kalem-4: 24
Kalem-5: 34,5
Kalem-6: 41
Kalem-7: 52
Kalem-8: 24
Kalem-9: 27,5

Kontrol:
Toplam = 243

Oranlar da sınırlar içinde kalıyor

Yüzde kontrolü:
Kalem-1 → 4,12%  (aralık: 3,5%–5,1%)
Kalem-2 → 4,94%  (aralık: 4,3%–6,0%)
Kalem-3 → 7,41%  (aralık: 6,5%–8,4%)
Kalem-4 → 9,88%  (aralık: 9,0%–11,0%)
Kalem-5 → 14,20% (aralık: 12,1%–14,3%)
Kalem-6 → 16,87% (aralık: 15,8%–18,0%)
Kalem-7 → 21,40% (aralık: 19,0%–22,0%)
Kalem-8 → 9,88%  (aralık: 8,0%–10,2%)
Kalem-9 → 11,32% (aralık: 9,5%–13,0%)

Yani pratik cevap:
I14 hücresini 27,5 yapmanız tek başına yeterli.
Excel’de bunu daha sistematik yapmak isterseniz en doğru yol:

amaç hücresi: toplam farkı 0 yapmak

kısıtlar:

SUM(I6:I14)=243
her satır için D satırı <= I/243*100 <= E satırı
I10=34,5

Bunu Solver ile çok rahat çözersiniz

 

[muhasebeciyiz]

deneyiniz

 

[modoste]

ilginiz için teşekkür ederin sayın hocam
sorunun anlaşılması açısından basit bir örnekleme yapmıştım. çözümünüzü anladım sayın hocam
en genel anlamda sorum şu
Kalem-1,Kalem-2.... Kalem100 tane olan bir listede
bir veya birden fazla kalemin tutarını değiştirip diğerlerinin tutarlarının bulunması ile ile ilgili makrolu çözüm üretebilir miyiz
dediğiniz gibi onlarca yüzlerce alternatif çözümler oluşabiliyor.

 

[muhasebeciyiz]

Kural bazlı dağıtım

Mantık:
Toplam sabit olacak
Kullanıcı bazı kalemlerin yeni tutarını değiştirecek
Oluşan fark, değişmeyen diğer kalemlere dağıtılacak
Dağıtım da bir kurala göre yapılacak

Örnek kurallar:

mevcut tutar oranına göre dağıt
sadece seçilen kalemlere dağıt
alt/üst sınırları aşanları dışarıda bırak
kalan farkı tekrar diğer uygun kalemlere yeniden dağıt
Bu yöntem tamamen VBA ile yapılır. En esnek yöntem budur.

Çok genel matematik modeli

Elimizde:

toplam hedef: T
kalemler: x1, x2, ..., x100
değiştirilen kalemler sabit
diğerleri bulunacak

her kalem için:
alt_i <= xi <= ust_i

Ayrıca:
x1 + x2 + ... + x100 = T
Eğer bazı kalemler kullanıcı tarafından değiştirildiyse, onlar sabitlenir. Geriye kalanlar dağıtılır.

 

[muhasebeciyiz]

Sayfa düzeni

Örneğin:
A: Kalem adı
B: Eski tutar
C: Alt sınır
D: Üst sınır
E: Manuel yeni tutar girildi mi? (E/H veya 1/0)
F: Yeni tutar
G: Sonuç oranı
H: Durum

Option Explicit

Sub KalemleriDengele()

    Dim ws As Worksheet
    Dim sonSatir As Long
    Dim i As Long
    
    Dim hedefToplam As Double
    Dim sabitToplam As Double
    Dim serbestEskiToplam As Double
    Dim kalanToplam As Double
    
    Dim eskiTutar() As Double
    Dim yeniTutar() As Double
    Dim altSinir() As Double
    Dim ustSinir() As Double
    Dim manuelMi() As Boolean
    Dim aktifMi() As Boolean
    
    Set ws = ThisWorkbook.Worksheets("Sayfa1")
    
    sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    hedefToplam = ws.Range("J1").Value
    
    ReDim eskiTutar(2 To sonSatir)
    ReDim yeniTutar(2 To sonSatir)
    ReDim altSinir(2 To sonSatir)
    ReDim ustSinir(2 To sonSatir)
    ReDim manuelMi(2 To sonSatir)
    ReDim aktifMi(2 To sonSatir)
    
    For i = 2 To sonSatir
        eskiTutar(i) = ws.Cells(i, "B").Value
        altSinir(i) = ws.Cells(i, "C").Value
        ustSinir(i) = ws.Cells(i, "D").Value
        
        If Trim(ws.Cells(i, "E").Value) <> "" Then
            manuelMi(i) = True
            yeniTutar(i) = ws.Cells(i, "E").Value
        Else
            manuelMi(i) = False
            yeniTutar(i) = eskiTutar(i)
        End If
        
        aktifMi(i) = Not manuelMi(i)
    Next i
    
    sabitToplam = 0
    For i = 2 To sonSatir
        If manuelMi(i) Then
            sabitToplam = sabitToplam + yeniTutar(i)
        End If
    Next i
    
    serbestEskiToplam = 0
    For i = 2 To sonSatir
        If Not manuelMi(i) Then
            serbestEskiToplam = serbestEskiToplam + eskiTutar(i)
        End If
    Next i
    
    kalanToplam = hedefToplam - sabitToplam
    
    If kalanToplam < 0 Then
        MsgBox "Hata", vbCritical
        Exit Sub
    End If
    
    If serbestEskiToplam = 0 And kalanToplam <> 0 Then
        MsgBox "Hata", vbCritical
        Exit Sub
    End If
    
    For i = 2 To sonSatir
        If Not manuelMi(i) Then
            yeniTutar(i) = eskiTutar(i) / serbestEskiToplam * kalanToplam
        End If
    Next i
    
    Dim degisti As Boolean
    Dim serbestToplam As Double
    Dim dagitilacak As Double
    
    Do
        degisti = False
        dagitilacak = hedefToplam
        
        For i = 2 To sonSatir
            If manuelMi(i) Then
                dagitilacak = dagitilacak - yeniTutar(i)
            End If
        Next i
        
        For i = 2 To sonSatir
            If Not manuelMi(i) And aktifMi(i) Then
                If yeniTutar(i) < altSinir(i) Then
                    yeniTutar(i) = altSinir(i)
                    aktifMi(i) = False
                    degisti = True
                ElseIf yeniTutar(i) > ustSinir(i) Then
                    yeniTutar(i) = ustSinir(i)
                    aktifMi(i) = False
                    degisti = True
                End If
            End If
        Next i
        
        If degisti Then
            For i = 2 To sonSatir
                If Not manuelMi(i) And Not aktifMi(i) Then
                    dagitilacak = dagitilacak - yeniTutar(i)
                End If
            Next i
            
            serbestToplam = 0
            For i = 2 To sonSatir
                If Not manuelMi(i) And aktifMi(i) Then
                    serbestToplam = serbestToplam + eskiTutar(i)
                End If
            Next i
            
            If serbestToplam = 0 And Abs(dagitilacak) > 0.0001 Then
                MsgBox "Hata", vbCritical
                Exit Sub
            End If
            
            For i = 2 To sonSatir
                If Not manuelMi(i) And aktifMi(i) Then
                    yeniTutar(i) = eskiTutar(i) / serbestToplam * dagitilacak
                End If
            Next i
        End If
        
    Loop While degisti
    
    Dim kontrolToplam As Double
    kontrolToplam = 0
    
    For i = 2 To sonSatir
        kontrolToplam = kontrolToplam + yeniTutar(i)
        ws.Cells(i, "F").Value = Round(yeniTutar(i), 4)
    Next i
    
    ws.Range("J2").Value = kontrolToplam
    
End Sub

Manuel girilen kalemleri sabit tutuyor
Diğerlerini eski tutarlarına göre oransal dağıtıyor
Alt/üst sınır aşılırsa o kalemi sınırda kilitliyor
Kalan farkı kalan kalemlere tekrar dağıtıyor

 

[modoste]

sayın hocam örnek excel dosya yapabilir misiniz
100 kalemli bir çalışma olabilir mi