Soru Satışları eşit dağıtma

[kimki]

Selamlar,
Ekteki dosyada bölge satışları var ve bunların bağlı olduğu Zone lar. Burada bölgelerin belli satışlar var , ben burada zone satışlarını birbirine en yakın yapmak istiyorum. Normalde bölgelerin isimlerini el ile değiştirerek manuel yapıyordum. Bu konuda yardımcı olabilir misiniz ?

 

[uzerm]

bende bunu arıyodum

 

[kimki]

merhaba tekrardan, fikri olan yok mu ? nasıl yapabiliriz ?

 

[Muhammet Okumuş]

Sub YakınDeğerBul()
Application.ScreenUpdating = False
Range("K2:L17") = Range("H2:I17").Value
Range("J2:J17") = "=RAND()"
Range("L19") = "=AVERAGE(L2:L5)"
Range("L20") = "=AVERAGE(L6:L9)"
Range("L21") = "=AVERAGE(L10:L13)"
Range("L22") = "=AVERAGE(L14:L17)"
Range("L23") = "=MAX(L19:L22)-MIN(L19:L22)"
a = WorksheetFunction.Max(Range("E3:E18")) - WorksheetFunction.Min(Range("E3:E18"))
ilk = a
ilk = Format(ilk, "0.00")
For i = 1 To 1000
Range("J2:L17").Sort Range("J2")
If Range("L23") < a Then
Range("B3:B18") = Range("K2:K17").Value
a = Range("L23").Value
End If
Next
son = a
son = Format(son, "0.00")
Range("J2:L23") = ""
fark = Format(ilk - son, "0.00")
MsgBox "İlk : " & ilk & vbLf & "Son : " & son & vbLf & "Azalma : " & fark
End Sub

Kodu deneyiniz. Kod en yakın sonuç bulma garantisini vermez. Döngü sayısını artırırsanız daha yakın bulma olasılığınız artar.

 

[kimki]

@Muhammet Okumuş teşekkürler. Tam istedigim olmus elinize saglik.

 

[ÖmerBey]

Sayın Muhammet Okumuş'un hazırladığı koddan çok farklı bir tarafı yok ama hazırlamıştım, ziyan olmasın. Belki birisinin daha işine yarar.
İyi çalışmalar...

Sub kod()
dz = Range("H2:I17")
dz2 = Range("B3:C18")
ort = WorksheetFunction.Average(Range("I2:I17"))

For a = LBound(dz2) To UBound(dz2) Step 4
    frke = frke + Abs(ort - WorksheetFunction.Average(dz2(a, 2), dz2(a + 1, 2), dz2(a + 2, 2), dz2(a + 3, 2)))
Next

Randomize
For deneme = 1 To 100000
    For a = LBound(dz) To UBound(dz)
        r = Int(Rnd * 16 + 1)
        x = dz(a, 1)
        dz(a, 1) = dz(r, 1)
        dz(r, 1) = x
        
        x = dz(a, 2)
        dz(a, 2) = dz(r, 2)
        dz(r, 2) = x
    Next
    frk = 0
    For a = LBound(dz) To UBound(dz) Step 4
        frk = frk + Abs(ort - WorksheetFunction.Average(dz(a, 2), dz(a + 1, 2), dz(a + 2, 2), dz(a + 3, 2)))
    Next
    If frk < frke Then
        frke = frk
        dz2 = dz
        If frk = 0 Then GoTo tmm
    End If
    
Next
tmm:
Range("B3:B18") = dz2
MsgBox "İşlem tamamlandı" & vbLf & "Tolerans: " & Round(frke, 2)
End Sub

 

[Muhammet Okumuş]

Ömer Bey, dizilerle çözüm en güzel olanıdır. Ben dizilere çok hakim değilim. Dizi ile kod yazdım ama amatörce oldu biraz. Sizin kodlarınıza şu koşul eklemelisiniz. Eğer bulunan sonuç başlangıçtan küçük değilse işlem yapmasın. Kodunuz küçük olan farkı büyütüyor.

Sub Dizi()
Range("N1") = Time
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Randomize
ilk = WorksheetFunction.Max(Range("E3:E18")) - WorksheetFunction.Min(Range("E3:E18"))
bas = ilk
For t = 1 To 50000
d1 = 0
d2 = 0
d3 = 0
d4 = 0
a = Range("H2:I17").Value
Dim sırala(3, 0)
Dim tablo(16, 2)
Dim tablo1(16, 1)



For i = 1 To 16
tablo(i - 1, 0) = Rnd()
tablo(i - 1, 1) = a(i, 1)
tablo(i - 1, 2) = a(i, 2)
Next


For a = 0 To 14
For b = a + 1 To 15
If tablo(a, 0) > tablo(b, 0) Then
Txt1 = tablo(a, 0)
Txt2 = tablo(a, 1)
Txt3 = tablo(a, 2)
tablo(a, 0) = tablo(b, 0)
tablo(a, 1) = tablo(b, 1)
tablo(a, 2) = tablo(b, 2)
tablo(b, 0) = Txt1
tablo(b, 1) = Txt2
tablo(b, 2) = Txt3
Txt1 = ""
Txt2 = ""
Txt3 = ""
End If
Next b
Next a

For i = 0 To 3
d1 = tablo(i, 2) + d1
d2 = tablo(i + 4, 2) + d2
d3 = tablo(i + 8, 2) + d3
d4 = tablo(i + 12, 2) + d4

Next

sırala(0, 0) = d1 / 4
sırala(1, 0) = d2 / 4
sırala(2, 0) = d3 / 4
sırala(3, 0) = d4 / 4



For a = 0 To 2
For b = a + 1 To 3
If sırala(a, 0) > sırala(b, 0) Then
Txt = sırala(a, 0)
sırala(a, 0) = sırala(b, 0)
sırala(b, 0) = Txt
Txt = ""
End If
Next b
Next a

son = sırala(3, 0) - sırala(0, 0)

If son < ilk Then
For i = 0 To 15
tablo1(i, 0) = tablo(i, 1)
Next
Range("B3").Resize(16, 1) = tablo1



ilk = son

End If
Next t
fark = Format(bas - ilk, "0.00")
If fark = 0 Then
MsgBox "Daha iyi sonuç yok."
Else
MsgBox "İlk : " & bas & vbLf & "Son : " & ilk & vbLf & "Azalma : " & fark
End If
Application.Calculation = xlCalculationAutomatic
Range("N2") = Time
End Sub

 

[ÖmerBey]

Ömer Bey, dizilerle çözüm en güzel olanıdır. Ben dizilere çok hakim değilim. Dizi ile kod yazdım ama amatörce oldu biraz. Sizin kodlarınıza şu koşul eklemelisiniz. Eğer bulunan sonuç başlangıçtan küçük değilse işlem yapmasın. Kodunuz küçük olan farkı büyütüyor.

Uyarınız için teşekkürler,
Ben bu ihtimali gözden kaçırmışım. Her seferinde sıfırdan hesaplama yapılması şeklinde tasarlamıştım, uyarınız doğrultusunda kodu güncelledim.
Tekrar teşekkürler...