Maximum Toplam Optimizasyonu - VBA

cnas · 18 Mart 2025

Bir proje üzerinde çalışmaktayım. Bu projenin içeriğinde ekte bulabileceğiniz excelde bulunan tablonun içerisinde 14. Satırda bulunan Kolon toplamını alan SUM formüllerinin minimize edilmesi amaçlanmakta. 3. ile 12. Satırlar ise 5 dakikalık zaman aralıklarındaki toplam ihtiyacı hücre hücre belirtmekte. 14. Satırda bulunan Kolon toplamlarını minimize etmek için satırlarda bulunan sayıları kaydırmak gerekiyor. Bu sayıların kaydırılması sonucunda en optimal diptoplamları elde ediyor olacağım.

Bu işlemi yaparken bazı kısıtlar mevcut;

1- Kaydırılacak olan sayılar grup halinde taşınabilmekteler. (Örneğin: Bir satırda 3 - 3 - 3 olarak yazan bir sayı grubu yine 3 - 3 - 3 olarak taşınmalı.
2- Kaydırmalar sadece Mavi hücreler arasında yapılmalı ve mavi hücre dışına taşmamalı.
3- Bir satırda bulunan sayı grubu farklı bir satıra taşınamaz, aynı satırda kaydırma yapılmalı.

Günlerdir VBA Kod yazarak bu optimizasyonu yaptırmaya çalıştım ama bir yolunu bulamadım. Desteklerinizi rica ederim, gerçekten bir çıkış yolu bulamadım

pitchoute · 19 Mart 2025

Merhaba, yedep alıp deneyip sonucu paylaşabilir misiniz;

Kod:

Sub OptimizeColumnTotals()
    Dim dataRange As Range
    Dim blueRange As Range
    Dim ws As Worksheet
    Dim rowIndex As Integer
    Dim i As Integer, j As Integer
    Dim bestScore As Double
    Dim currentScore As Double
    Dim bestOffset As Integer
    Dim groupStartCol As Integer
    Dim groupEndCol As Integer
    Dim inGroup As Boolean
    Dim groupValue As Integer
    Dim rowValues() As Variant
    Dim rowColors() As Boolean
    Dim colTotals() As Integer
    Dim numCols As Integer
    Dim iterationCount As Integer
    
    Set ws = ActiveSheet
    
    Set dataRange = ws.Range("C3:AG12")
    numCols = dataRange.Columns.Count
    ReDim colTotals(1 To numCols)

    For i = 1 To numCols
        colTotals(i) = Application.WorksheetFunction.Sum(dataRange.Columns(i))
    Next i
    
    For rowIndex = 3 To 12
        ReDim rowValues(1 To numCols)
        ReDim rowColors(1 To numCols)

        For i = 1 To numCols
            rowValues(i) = ws.Cells(rowIndex, i + 2).Value
            If ws.Cells(rowIndex, i + 2).Interior.ColorIndex = 37 Or _
               ws.Cells(rowIndex, i + 2).Interior.ColorIndex = 8 Or _
               ws.Cells(rowIndex, i + 2).Interior.Color = RGB(197, 217, 241) Then
                rowColors(i) = True
            Else
                rowColors(i) = False
            End If
        Next i
        
        If WorksheetFunction.CountIf(ws.Rows(rowIndex).Cells, "<>") > 0 Then
            i = 1
            iterationCount = 0
            Do While i <= numCols
                If Not IsEmpty(rowValues(i)) And rowColors(i) Then
                    groupStartCol = i
                    groupValue = rowValues(i)
                    j = i
                    Do While j <= numCols And rowValues(j) = groupValue And rowColors(j)
                        j = j + 1
                    Loop
                    groupEndCol = j - 1
                    bestOffset = 0
                    bestScore = CalculateScoreForColumnTotals(colTotals)
                    For j = 1 To numCols
                        If IsValidShift(j, groupStartCol, groupEndCol, numCols, rowColors) Then
                            currentScore = CalculateScoreForShift(colTotals, groupStartCol, groupEndCol, j, groupValue)

                            If currentScore < bestScore Then
                                bestScore = currentScore
                                bestOffset = j - groupStartCol
                            End If
                        End If
                    Next j
                    
                    If bestOffset <> 0 Then
                        ApplyShift ws, rowIndex, groupStartCol, groupEndCol, bestOffset, colTotals, groupValue
                    End If
                    i = groupEndCol + 1
                Else
                    i = i + 1
                End If
                iterationCount = iterationCount + 1
                If iterationCount > 1000 Then Exit Do
            Loop
        End If
    Next rowIndex
    
    For i = 1 To numCols
        ws.Cells(14, i + 2).Value = Application.WorksheetFunction.Sum(ws.Range(ws.Cells(3, i + 2), ws.Cells(12, i + 2)))
    Next i
    MsgBox "Optimizasyon tamamlandı.", vbInformation
End Sub

Function CalculateScoreForColumnTotals(colTotals() As Integer) As Double
    Dim score As Double
    Dim i As Integer
    score = 0
    For i = LBound(colTotals) To UBound(colTotals)
        score = score + colTotals(i) ^ 2
    Next i
    CalculateScoreForColumnTotals = score
End Function

Function CalculateScoreForShift(colTotals() As Integer, startCol As Integer, endCol As Integer, newStartCol As Integer, value As Integer) As Double
    Dim tempTotals() As Integer
    Dim groupWidth As Integer
    Dim i As Integer
    
    ReDim tempTotals(LBound(colTotals) To UBound(colTotals))
    For i = LBound(colTotals) To UBound(colTotals)
        tempTotals(i) = colTotals(i)
    Next i
    
    groupWidth = endCol - startCol + 1
    For i = startCol To endCol
        tempTotals(i) = tempTotals(i) - value
    Next i
    
    For i = newStartCol To newStartCol + groupWidth - 1
        If i >= LBound(tempTotals) And i <= UBound(tempTotals) Then
            tempTotals(i) = tempTotals(i) + value
        End If
    Next i
    
    CalculateScoreForShift = CalculateScoreForColumnTotals(tempTotals)
End Function

Function IsValidShift(newStartCol As Integer, oldStartCol As Integer, oldEndCol As Integer, numCols As Integer, rowColors() As Boolean) As Boolean
    Dim groupWidth As Integer
    Dim i As Integer
    groupWidth = oldEndCol - oldStartCol + 1
    
    If newStartCol < 1 Or newStartCol + groupWidth - 1 > numCols Then
        IsValidShift = False
        Exit Function
    End If
    
    For i = newStartCol To newStartCol + groupWidth - 1
        If Not rowColors(i) Then
            IsValidShift = False
            Exit Function
        End If
    Next i
    IsValidShift = True
End Function

Sub ApplyShift(ws As Worksheet, rowIndex As Integer, startCol As Integer, endCol As Integer, offset As Integer, colTotals() As Integer, value As Integer)
    Dim i As Integer
    Dim newStartCol As Integer
    Dim groupWidth As Integer
    
    groupWidth = endCol - startCol + 1
    newStartCol = startCol + offset
    
    For i = startCol To endCol
        ws.Cells(rowIndex, i + 2).ClearContents
        colTotals(i) = colTotals(i) - value
    Next i
    
    For i = newStartCol To newStartCol + groupWidth - 1
        ws.Cells(rowIndex, i + 2).Value = value
        colTotals(i) = colTotals(i) + value
    Next i
End Sub

cnas · 19 Mart 2025

Merhaba, Cevabınız ve desteğiniz için çok teşekkür ederim. Yazdığınız kod aktif olarak çalışıyor gibi gözüküyor test etme şansım oldu. 2 Farklı değişiklik yaptım, Mavi rengin renk kodunu ekledim ve işlem aralığını düzenledim. Fakat sadece düzelmesi gereken 2 nokta kaldı, o kısmıda denedim ama yapamadım yardımcı olabilirseniz çok sevinirim

.

1- 3-3-3-1-1 gibi sayıların farklı olduğu sayı gruplarını satır arasında taşırken 3-3-3'ü sabit bırakıp 1-1'i taşıyor, eğer satırdaki bütün sayılar aynı ise doğru bir taşıma yapıyor.

2- Optimizasyon yapmakta kod, fakat doğru sonucu vermemekte, örneğin bende bulunan örnek veride Minimum değer 7 olarak bulunmalı fakat 8 olarak buluyor kod. Bir satırda kaydırma yapabileceğine rağmen yapmamış. (İterasyon sayısı ile ilgili olabilir mi?)

Tekrar çok teşekkür ederim.

Kod:

Sub OptimizeColumnTotals()
    Dim dataRange As Range
    Dim ws As Worksheet
    Dim rowIndex As Integer
    Dim i As Integer, j As Integer
    Dim bestScore As Double
    Dim currentScore As Double
    Dim bestOffset As Integer
    Dim groupStartCol As Integer
    Dim groupEndCol As Integer
    Dim groupValue As Integer
    Dim rowValues() As Variant
    Dim rowColors() As Boolean
    Dim colTotals() As Integer
    Dim numCols As Integer
    Dim iterationCount As Integer
    Dim groupIndexes() As Integer
    Dim groupValues() As Variant
    
    Set ws = ActiveSheet
    
    Set dataRange = ws.Range("F3:AG12") ' Yeni işlem aralığı F3:AG12
    numCols = dataRange.Columns.count
    ReDim colTotals(1 To numCols)

    ' Sütun toplamlarını hesapla
    For i = 1 To numCols
        colTotals(i) = Application.WorksheetFunction.Sum(dataRange.Columns(i))
    Next i
    
    ' Satırları işleme
    For rowIndex = 3 To 12
        ReDim rowValues(1 To numCols)
        ReDim rowColors(1 To numCols)

        ' Satırdaki hücreleri ve renklerini al
        For i = 1 To numCols
            rowValues(i) = ws.Cells(rowIndex, i + 5).value ' F3'te başlıyoruz, bu yüzden i+5
            ' Yeni renk kodu RGB(202, 237, 251) kullanılıyor
            If ws.Cells(rowIndex, i + 5).Interior.Color = RGB(202, 237, 251) Then
                rowColors(i) = True
            Else
                rowColors(i) = False
            End If
        Next i
        
        ' Satırda boş hücre olup olmadığını kontrol et
        If WorksheetFunction.CountIf(ws.Rows(rowIndex).Cells, "<>") > 0 Then
            i = 1
            iterationCount = 0
            Do While i <= numCols
                If Not IsEmpty(rowValues(i)) And rowColors(i) Then
                    groupStartCol = i
                    groupValue = rowValues(i)
                    j = i
                    ' Aynı değere sahip hücrelerin tümünü bul
                    Do While j <= numCols And rowValues(j) = groupValue And rowColors(j)
                        j = j + 1
                    Loop
                    groupEndCol = j - 1
                    bestOffset = 0
                    bestScore = CalculateScoreForColumnTotals(colTotals)
                    
                    ' Bu grup değerlerini ve indexlerini al
                    ReDim groupValues(groupEndCol - groupStartCol + 1)
                    For k = groupStartCol To groupEndCol
                        groupValues(k - groupStartCol + 1) = rowValues(k)
                    Next k
                    
                    ' Kolonları kaydırarak puan hesapla
                    For j = 1 To numCols
                        If IsValidShift(j, groupStartCol, groupEndCol, numCols, rowColors) Then
                            currentScore = CalculateScoreForShift(colTotals, groupStartCol, groupEndCol, j, groupValues)

                            If currentScore < bestScore Then
                                bestScore = currentScore
                                bestOffset = j - groupStartCol
                            End If
                        End If
                    Next j
                    
                    ' En iyi kaydırmayı uygula
                    If bestOffset <> 0 Then
                        ApplyShift ws, rowIndex, groupStartCol, groupEndCol, bestOffset, colTotals, groupValues
                    End If
                    i = groupEndCol + 1
                Else
                    i = i + 1
                End If
                iterationCount = iterationCount + 1
                If iterationCount > 1000 Then Exit Do
            Loop
        End If
    Next rowIndex
    
    ' Son sütun toplamlarını yaz
    For i = 1 To numCols
        ws.Cells(14, i + 5).value = Application.WorksheetFunction.Sum(ws.Range(ws.Cells(3, i + 5), ws.Cells(12, i + 5)))
    Next i
    MsgBox "Optimizasyon tamamlandı.", vbInformation
End Sub

Function CalculateScoreForColumnTotals(colTotals() As Integer) As Double
    Dim score As Double
    Dim i As Integer
    score = 0
    For i = LBound(colTotals) To UBound(colTotals)
        score = score + colTotals(i) ^ 2
    Next i
    CalculateScoreForColumnTotals = score
End Function

Function CalculateScoreForShift(colTotals() As Integer, startCol As Integer, endCol As Integer, newStartCol As Integer, groupValues() As Variant) As Double
    Dim tempTotals() As Integer
    Dim groupWidth As Integer
    Dim i As Integer
    
    ReDim tempTotals(LBound(colTotals) To UBound(colTotals))
    For i = LBound(colTotals) To UBound(colTotals)
        tempTotals(i) = colTotals(i)
    Next i
    
    groupWidth = endCol - startCol + 1
    ' İlk grubu kaldır
    For i = startCol To endCol
        tempTotals(i) = tempTotals(i) - groupValues(i - startCol + 1)
    Next i
    
    ' Yeni konumda grubu ekle
    For i = newStartCol To newStartCol + groupWidth - 1
        If i >= LBound(tempTotals) And i <= UBound(tempTotals) Then
            tempTotals(i) = tempTotals(i) + groupValues(i - newStartCol + 1)
        End If
    Next i
    
    CalculateScoreForShift = CalculateScoreForColumnTotals(tempTotals)
End Function

Function IsValidShift(newStartCol As Integer, oldStartCol As Integer, oldEndCol As Integer, numCols As Integer, rowColors() As Boolean) As Boolean
    Dim groupWidth As Integer
    Dim i As Integer
    groupWidth = oldEndCol - oldStartCol + 1
    
    If newStartCol < 1 Or newStartCol + groupWidth - 1 > numCols Then
        IsValidShift = False
        Exit Function
    End If
    
    For i = newStartCol To newStartCol + groupWidth - 1
        If Not rowColors(i) Then
            IsValidShift = False
            Exit Function
        End If
    Next i
    IsValidShift = True
End Function

Sub ApplyShift(ws As Worksheet, rowIndex As Integer, startCol As Integer, endCol As Integer, offset As Integer, colTotals() As Integer, groupValues() As Variant)
    Dim i As Integer
    Dim newStartCol As Integer
    Dim groupWidth As Integer
    
    groupWidth = endCol - startCol + 1
    newStartCol = startCol + offset
    
    ' Eski hücreleri temizle ve kolondaki toplamları güncelle
    For i = startCol To endCol
        ws.Cells(rowIndex, i + 5).ClearContents
        colTotals(i) = colTotals(i) - groupValues(i - startCol + 1)
    Next i
    
    ' Yeni konumda hücrelere değerleri yerleştir ve kolondaki toplamları güncelle
    For i = newStartCol To newStartCol + groupWidth - 1
        ws.Cells(rowIndex, i + 5).value = groupValues(i - newStartCol + 1)
        colTotals(i) = colTotals(i) + groupValues(i - newStartCol + 1)
    Next i
End Sub

pitchoute · 19 Mart 2025

Şöyle dener misiniz hocam;

Kod:

Sub OptimizeColumnTotals()
    Dim dataRange As Range
    Dim ws As Worksheet
    Dim rowIndex As Integer
    Dim i As Integer, j As Integer, k As Integer
    Dim bestScore As Double
    Dim currentScore As Double
    Dim bestOffset As Integer
    Dim groupStartCol As Integer
    Dim groupEndCol As Integer
    Dim groupValue As Integer
    Dim rowValues() As Variant
    Dim rowColors() As Boolean
    Dim colTotals() As Integer
    Dim numCols As Integer
    Dim iterationCount As Integer
    Dim groupValues() As Variant
    
    Set ws = ActiveSheet
    
    Set dataRange = ws.Range("F3:AG12")
    numCols = dataRange.Columns.Count
    ReDim colTotals(1 To numCols)

    For i = 1 To numCols
        colTotals(i) = Application.WorksheetFunction.Sum(dataRange.Columns(i))
    Next i
    
    For rowIndex = 3 To 12
        ReDim rowValues(1 To numCols)
        ReDim rowColors(1 To numCols)

        For i = 1 To numCols
            rowValues(i) = ws.Cells(rowIndex, i + 5).Value
            If ws.Cells(rowIndex, i + 5).Interior.Color = RGB(202, 237, 251) Then
                rowColors(i) = True
            Else
                rowColors(i) = False
            End If
        Next i
        
        If WorksheetFunction.CountIf(ws.Rows(rowIndex).Cells, "<>") > 0 Then
            i = 1
            iterationCount = 0
            Do While i <= numCols
                If Not IsEmpty(rowValues(i)) And rowColors(i) Then
                    groupStartCol = i
                    j = i
                    Do While j <= numCols And rowColors(j)
                        j = j + 1
                    Loop
                    groupEndCol = j - 1
                    
                    If groupEndCol < groupStartCol Then
                        i = i + 1
                        Continue Do
                    End If
                    
                    bestOffset = 0
                    bestScore = CalculateScoreForColumnTotals(colTotals)
                    
                    ReDim groupValues(groupEndCol - groupStartCol + 1)
                    For k = groupStartCol To groupEndCol
                        groupValues(k - groupStartCol + 1) = rowValues(k)
                    Next k
                    
                    For j = 1 To numCols
                        If IsValidShift(j, groupStartCol, groupEndCol, numCols, rowColors) Then
                            currentScore = CalculateScoreForShift(colTotals, groupStartCol, groupEndCol, j, groupValues)

                            If currentScore < bestScore Then
                                bestScore = currentScore
                                bestOffset = j - groupStartCol
                            End If
                        End If
                    Next j
                    
                    If bestOffset <> 0 Then
                        ApplyShift ws, rowIndex, groupStartCol, groupEndCol, bestOffset, colTotals, groupValues
                    End If
                    i = groupEndCol + 1
                Else
                    i = i + 1
                End If
                iterationCount = iterationCount + 1
                If iterationCount > 5000 Then Exit Do
            Loop
        End If
    Next rowIndex
    
    ' Son sütun toplamlarını yaz
    For i = 1 To numCols
        ws.Cells(14, i + 5).Value = Application.WorksheetFunction.Sum(ws.Range(ws.Cells(3, i + 5), ws.Cells(12, i + 5)))
    Next i
    MsgBox "Optimizasyon tamamlandı.", vbInformation
End Sub

Function CalculateScoreForColumnTotals(colTotals() As Integer) As Double
    Dim mean As Double
    Dim variance As Double
    Dim i As Integer
    
    mean = 0
    For i = LBound(colTotals) To UBound(colTotals)
        mean = mean + colTotals(i)
    Next i
    mean = mean / (UBound(colTotals) - LBound(colTotals) + 1)
    
    variance = 0
    For i = LBound(colTotals) To UBound(colTotals)
        variance = variance + (colTotals(i) - mean) ^ 2
    Next i
    
    CalculateScoreForColumnTotals = variance
End Function

Function CalculateScoreForShift(colTotals() As Integer, startCol As Integer, endCol As Integer, newStartCol As Integer, groupValues() As Variant) As Double
    Dim tempTotals() As Integer
    Dim groupWidth As Integer
    Dim i As Integer
    
    ReDim tempTotals(LBound(colTotals) To UBound(colTotals))
    For i = LBound(colTotals) To UBound(colTotals)
        tempTotals(i) = colTotals(i)
    Next i
    
    groupWidth = endCol - startCol + 1
    For i = startCol To endCol
        tempTotals(i) = tempTotals(i) - groupValues(i - startCol + 1)
    Next i
    
    For i = newStartCol To newStartCol + groupWidth - 1
        If i >= LBound(tempTotals) And i <= UBound(tempTotals) Then
            tempTotals(i) = tempTotals(i) + groupValues(i - newStartCol + 1)
        End If
    Next i
    
    CalculateScoreForShift = CalculateScoreForColumnTotals(tempTotals)
End Function

Function IsValidShift(newStartCol As Integer, oldStartCol As Integer, oldEndCol As Integer, numCols As Integer, rowColors() As Boolean) As Boolean
    Dim groupWidth As Integer
    Dim i As Integer
    groupWidth = oldEndCol - oldStartCol + 1
    
    If newStartCol < 1 Or newStartCol + groupWidth - 1 > numCols Then
        IsValidShift = False
        Exit Function
    End If
    
    For i = newStartCol To newStartCol + groupWidth - 1
        If Not rowColors(i) Then
            IsValidShift = False
            Exit Function
        End If
    Next i
    
    If newStartCol = oldStartCol Then
        IsValidShift = False
        Exit Function
    End If
    
    IsValidShift = True
End Function

Sub ApplyShift(ws As Worksheet, rowIndex As Integer, startCol As Integer, endCol As Integer, offset As Integer, colTotals() As Integer, groupValues() As Variant)
    Dim i As Integer
    Dim newStartCol As Integer
    Dim groupWidth As Integer
    
    groupWidth = endCol - startCol + 1
    newStartCol = startCol + offset
    
    If offset = 0 Then Exit Sub
    
    For i = startCol To endCol
        ws.Cells(rowIndex, i + 5).ClearContents
        colTotals(i) = colTotals(i) - groupValues(i - startCol + 1)
    Next i
    
    For i = newStartCol To newStartCol + groupWidth - 1
        ws.Cells(rowIndex, i + 5).Value = groupValues(i - newStartCol + 1)
        colTotals(i) = colTotals(i) + groupValues(i - newStartCol + 1)
    Next i
End Sub

cnas · 19 Mart 2025

3 Farklı hata aldım hocam,

Subscript out of range hatasını alttaki 2 satır verdi sırasıyla:

Do While j <= numCols And j <= UBound(rowColors) And rowColors(j)

Do While j <= UBound(rowColors) And rowColors(j)

CalculateScoreForColumnTotals

Sub function not defined hatası verdi

pitchoute · 19 Mart 2025

Şöyle dener misiniz;

Kod:

Sub OptimizeColumnTotals()
    Dim dataRange As Range
    Dim ws As Worksheet
    Dim rowIndex As Integer
    Dim i As Integer, j As Integer, k As Integer
    Dim bestScore As Double
    Dim currentScore As Double
    Dim bestOffset As Integer
    Dim groupStartCol As Integer
    Dim groupEndCol As Integer
    Dim groupValue As Integer
    Dim rowValues() As Variant
    Dim rowColors() As Boolean
    Dim colTotals() As Integer
    Dim numCols As Integer
    Dim iterationCount As Integer
    Dim groupValues() As Variant
    
    Set ws = ActiveSheet
    
    Set dataRange = ws.Range("F3:AG12")
    numCols = dataRange.Columns.Count
    ReDim colTotals(1 To numCols)

    For i = 1 To numCols
        colTotals(i) = Application.WorksheetFunction.Sum(dataRange.Columns(i))
    Next i
    
    For rowIndex = 3 To 12
        ReDim rowValues(1 To numCols)
        ReDim rowColors(1 To numCols)

        For i = 1 To numCols
            rowValues(i) = ws.Cells(rowIndex, i + 5).Value
            If ws.Cells(rowIndex, i + 5).Interior.Color = RGB(202, 237, 251) Then
                rowColors(i) = True
            Else
                rowColors(i) = False
            End If
        Next i
        
        If WorksheetFunction.CountIf(ws.Rows(rowIndex).Cells, "<>") > 0 Then
            i = 1
            iterationCount = 0
            Do While i <= numCols
                If Not IsEmpty(rowValues(i)) And rowColors(i) Then
                    groupStartCol = i
                    groupValue = rowValues(i)
                    j = i
                    Do While j <= numCols And j <= UBound(rowColors) And rowColors(j)
                        If j <= UBound(rowValues) And rowValues(j) = groupValue Then
                            j = j + 1
                        Else
                            Exit Do
                        End If
                    Loop
                    groupEndCol = j - 1
                    
                    If groupEndCol < groupStartCol Then
                        i = i + 1
                        GoTo ContinueLoop
                    End If
                    
                    bestOffset = 0
                    bestScore = CalculateScoreForColumnTotals(colTotals)
                    
                    ReDim groupValues(groupEndCol - groupStartCol + 1)
                    For k = groupStartCol To groupEndCol
                        groupValues(k - groupStartCol + 1) = rowValues(k)
                    Next k
                    
                    For j = 1 To numCols
                        If IsValidShift(j, groupStartCol, groupEndCol, numCols, rowColors) Then
                            currentScore = CalculateScoreForShift(colTotals, groupStartCol, groupEndCol, j, groupValues)

                            If currentScore < bestScore Then
                                bestScore = currentScore
                                bestOffset = j - groupStartCol
                            End If
                        End If
                    Next j
                    
                    If bestOffset <> 0 Then
                        ApplyShift ws, rowIndex, groupStartCol, groupEndCol, bestOffset, colTotals, groupValues
                    End If
                    i = groupEndCol + 1
                Else
                    i = i + 1
                End If
ContinueLoop:
                iterationCount = iterationCount + 1
                If iterationCount > 1000 Then Exit Do
            Loop
        End If
    Next rowIndex
    
    For i = 1 To numCols
        ws.Cells(14, i + 5).Value = Application.WorksheetFunction.Sum(ws.Range(ws.Cells(3, i + 5), ws.Cells(12, i + 5)))
    Next i
    MsgBox "Optimizasyon tamamlandı.", vbInformation
End Sub

Function CalculateScoreForColumnTotals(colTotals() As Integer) As Double
    Dim score As Double
    Dim i As Integer
    
    score = 0
    For i = LBound(colTotals) To UBound(colTotals)
        score = score + colTotals(i) ^ 2
    Next i
    
    CalculateScoreForColumnTotals = score
End Function

Function CalculateScoreForShift(colTotals() As Integer, startCol As Integer, endCol As Integer, newStartCol As Integer, groupValues() As Variant) As Double
    Dim tempTotals() As Integer
    Dim groupWidth As Integer
    Dim i As Integer
    
    ReDim tempTotals(LBound(colTotals) To UBound(colTotals))
    For i = LBound(colTotals) To UBound(colTotals)
        tempTotals(i) = colTotals(i)
    Next i
    
    groupWidth = endCol - startCol + 1
    For i = startCol To endCol
        tempTotals(i) = tempTotals(i) - groupValues(i - startCol + 1)
    Next i
    
    For i = newStartCol To newStartCol + groupWidth - 1
        If i >= LBound(tempTotals) And i <= UBound(tempTotals) Then
            tempTotals(i) = tempTotals(i) + groupValues(i - newStartCol + 1)
        End If
    Next i
    
    CalculateScoreForShift = CalculateScoreForColumnTotals(tempTotals)
End Function

Function IsValidShift(newStartCol As Integer, oldStartCol As Integer, oldEndCol As Integer, numCols As Integer, rowColors() As Boolean) As Boolean
    Dim groupWidth As Integer
    Dim i As Integer
    groupWidth = oldEndCol - oldStartCol + 1
    
    If newStartCol < 1 Or newStartCol + groupWidth - 1 > numCols Then
        IsValidShift = False
        Exit Function
    End If
    
    For i = newStartCol To newStartCol + groupWidth - 1
        If i > UBound(rowColors) Or Not rowColors(i) Then
            IsValidShift = False
            Exit Function
        End If
    Next i
    
    If newStartCol = oldStartCol Then
        IsValidShift = False
        Exit Function
    End If
    
    IsValidShift = True
End Function

Sub ApplyShift(ws As Worksheet, rowIndex As Integer, startCol As Integer, endCol As Integer, offset As Integer, colTotals() As Integer, groupValues() As Variant)
    Dim i As Integer
    Dim newStartCol As Integer
    Dim groupWidth As Integer
    
    groupWidth = endCol - startCol + 1
    newStartCol = startCol + offset
    
    If offset = 0 Then Exit Sub
    
    For i = startCol To endCol
        ws.Cells(rowIndex, i + 5).ClearContents
        colTotals(i) = colTotals(i) - groupValues(i - startCol + 1)
    Next i
    
    For i = newStartCol To newStartCol + groupWidth - 1
        ws.Cells(rowIndex, i + 5).Value = groupValues(i - newStartCol + 1)
        colTotals(i) = colTotals(i) + groupValues(i - newStartCol + 1)
    Next i
End Sub

Maximum Toplam Optimizasyonu - VBA

cnas

pitchoute

cnas

pitchoute

cnas

pitchoute