Scribd
Upload
13 views27 pages

VBA Solver for Multiple Sheets

The document contains a series of VBA macros designed to run the Solver function on multiple Excel worksheets while excluding specified sheets. It includes error handling, diagnostics for failed Solver attempts, and the ability to log results in a separate sheet. The macros ensure that the Solver optimizes a specific cell by changing another cell within defined constraints.

Uploaded by

aarushi.asthana
Copyright
© All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as DOCX, PDF, TXT or read online on Scribd
13 views27 pages

VBA Solver for Multiple Sheets

The document contains a series of VBA macros designed to run the Solver function on multiple Excel worksheets while excluding specified sheets. It includes error handling, diagnostics for failed Solver attempts, and the ability to log results in a separate sheet. The macros ensure that the Solver optimizes a specific cell by changing another cell within defined constraints.

Uploaded by

aarushi.asthana
Copyright
© All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as DOCX, PDF, TXT or read online on Scribd

Sub SolveAllSheetsExceptExcluded()

Dim ws As Worksheet

Dim skipSheets As Variant

Dim sheetName As String

' Sheets to exclude from Solver

skipSheets = Array("Summary", "Sales", "Sales Input", "Python


Comparison")

For Each ws In [Link]

sheetName = [Link]

' Skip excluded sheets

If IsError([Link](sheetName, skipSheets, 0)) Then

On Error Resume Next ' Ignore errors on missing formulas

SolverReset

' Set objective: Minimize P6 by changing P4

SolverOk _

SetCell:=[Link]("P6").Address(True, True, xlA1, True), _

MaxMinVal:=2, _

ByChange:=[Link]("P4").Address(True, True, xlA1, True)

' Add constraints: 0 <= P4 <= 1

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1, True),


_
Relation:=3, FormulaText:="0"

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1, True),


_

Relation:=1, FormulaText:="1"

' Solve and keep result

SolverSolve UserFinish:=True

SolverFinish KeepFinal:=1

On Error GoTo 0

End If

Next ws

MsgBox "Solver completed on all applicable sheets."

End Sub

Sub SolveAllSheetsExceptExcluded()

Dim ws As Worksheet

Dim skipSheets As Variant

Dim sheetName As String

skipSheets = Array("Summary", "Sales", "Sales Input", "Python


Comparison")
For Each ws In [Link]

sheetName = [Link]

If IsError([Link](sheetName, skipSheets, 0)) Then

On Error Resume Next

SolverReset

SolverOk _

SetCell:=[Link]("P6").Address(True, True, xlA1, True), _

MaxMinVal:=2, _

ByChange:=[Link]("P4").Address(True, True, xlA1, True)

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1, True),


Relation:=3, FormulaText:="0"

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1, True),


Relation:=1, FormulaText:="1"

' Set solving method to GRG Nonlinear by positional argument

SolverOptions 1

SolverSolve UserFinish:=True

SolverFinish KeepFinal:=1

On Error GoTo 0

End If
Next ws

MsgBox "Solver (GRG Nonlinear) completed on all applicable sheets."

End Sub

Sub SolveAllSheetsExceptExcluded()

Dim ws As Worksheet

Dim skipSheets As Variant

Dim sheetName As String

skipSheets = Array("Summary", "Sales", "Sales Input", "Python


Comparison")

For Each ws In [Link]

sheetName = [Link]

If IsError([Link](sheetName, skipSheets, 0)) Then

On Error Resume Next

' Activate the sheet before running Solver

[Link]

SolverReset
SolverOk _

SetCell:=[Link]("P6").Address(True, True, xlA1, True), _

MaxMinVal:=2, _

ByChange:=[Link]("P4").Address(True, True, xlA1, True)

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1, True),


Relation:=3, FormulaText:="0"

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1, True),


Relation:=1, FormulaText:="1"

SolverOptions 1 ' GRG Nonlinear method

SolverSolve UserFinish:=True

SolverFinish KeepFinal:=1

On Error GoTo 0

End If

Next ws

MsgBox "Solver (GRG Nonlinear) completed on all applicable sheets."

End Sub

Sub SolveAllSheetsExceptExcluded()

Dim ws As Worksheet

Dim skipSheets As Variant


Dim sheetName As String

Dim result As Integer

skipSheets = Array("Summary", "Sales", "Sales Input", "Python


Comparison")

For Each ws In [Link]

sheetName = [Link]

If IsError([Link](sheetName, skipSheets, 0)) Then

On Error Resume Next

[Link]

SolverReset

SolverOk _

SetCell:=[Link]("P6").Address(True, True, xlA1, True), _

MaxMinVal:=2, _

ByChange:=[Link]("P4").Address(True, True, xlA1, True)

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1, True),


Relation:=3, FormulaText:="0"

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1, True),


Relation:=1, FormulaText:="1"

SolverOptions 1 ' GRG Nonlinear

' Run Solver and store the result


result = SolverSolve(UserFinish:=True)

If result = 0 Then

' Successful solve — finish and keep solution

SolverFinish KeepFinal:=1

Else

MsgBox "Solver could not find a solution on sheet: " &


sheetName, vbExclamation

End If

On Error GoTo 0

End If

Next ws

MsgBox "Solver finished processing all sheets."

End Sub

Sub SolveAllSheetsExceptExcluded()

Dim ws As Worksheet

Dim skipSheets As Variant

Dim sheetName As String

Dim result As Integer

skipSheets = Array("Summary", "Sales", "Sales Input", "Python


Comparison")
For Each ws In [Link]

sheetName = [Link]

If IsError([Link](sheetName, skipSheets, 0)) Then

On Error Resume Next

[Link]

SolverReset

' Objective: Minimize P6 by changing P4

SolverOk _

SetCell:=[Link]("P6").Address(True, True, xlA1, True), _

MaxMinVal:=2, _

ByChange:=[Link]("P4").Address(True, True, xlA1, True)

' Constraints: 0 <= P4 <= 1

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1, True),


Relation:=3, FormulaText:="0"

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1, True),


Relation:=1, FormulaText:="1"

' Set method to GRG Nonlinear

SolverOptions 1

' Suppress all Solver popups

result = SolverSolve(UserFinish:=True, ShowRef:=False)

If result = 0 Then
SolverFinish KeepFinal:=1 ' Keep solution

Else

[Link] "No solution found on sheet: " & sheetName

' Optional: SolverFinish KeepFinal:=2 ' Restore original values

End If

On Error GoTo 0

End If

Next ws

MsgBox "Solver processed all sheets. Check Debug window for failures
if any."

End Sub

Sub SolveAllSheetsExceptExcluded()

Dim ws As Worksheet

Dim skipSheets As Variant

Dim result As Integer

Dim sheetName As String

Dim failedSheets As String

skipSheets = Array("Summary", "Sales", "Sales Input", "Python


Comparison")

For Each ws In [Link]


sheetName = [Link]

If IsError([Link](sheetName, skipSheets, 0)) Then

' Ensure both cells exist and are numeric

If IsNumeric([Link]("P6").Value) And
IsNumeric([Link]("P4").Value) Then

On Error Resume Next

[Link]

SolverReset

SolverOk _

SetCell:=[Link]("P6").Address(True, True, xlA1, True), _

MaxMinVal:=2, _

ByChange:=[Link]("P4").Address(True, True, xlA1, True)

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1,


True), Relation:=3, FormulaText:="0"

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1,


True), Relation:=1, FormulaText:="1"

SolverOptions 1 ' GRG Nonlinear

result = SolverSolve(UserFinish:=True, ShowRef:=False)

If result = 0 Then

SolverFinish KeepFinal:=1

Else

failedSheets = failedSheets & sheetName & vbNewLine


End If

On Error GoTo 0

Else

failedSheets = failedSheets & sheetName & " (invalid P4 or P6)"


& vbNewLine

End If

End If

Next ws

If Len(failedSheets) > 0 Then

MsgBox "Solver could not solve the following sheets:" & vbNewLine &
failedSheets, vbExclamation

Else

MsgBox "Solver successfully processed all applicable sheets.",


vbInformation

End If

End Sub

Sub SolveAllSheetsExceptExcluded()

Dim ws As Worksheet, failedWs As Worksheet

Dim skipSheets As Variant

Dim result As Integer

Dim sheetName As String

Dim failRow As Long


' List of sheets to skip

skipSheets = Array("Summary", "Sales", "Sales Input", "Python


Comparison")

' Create or clear the "Failed Sheets" sheet

On Error Resume Next

Set failedWs = [Link]("Failed Sheets")

On Error GoTo 0

If failedWs Is Nothing Then

Set failedWs = [Link]

[Link] = "Failed Sheets"

Else

[Link]

End If

[Link]("A1").Value = "Sheets Solver Failed To Solve"

failRow = 2

For Each ws In [Link]

sheetName = [Link]

If IsError([Link](sheetName, skipSheets, 0)) Then

If IsNumeric([Link]("P6").Value) And
IsNumeric([Link]("P4").Value) Then

On Error Resume Next

[Link]

SolverReset
SolverOk _

SetCell:=[Link]("P6").Address(True, True, xlA1, True), _

MaxMinVal:=2, _

ByChange:=[Link]("P4").Address(True, True, xlA1, True)

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1,


True), Relation:=3, FormulaText:="0"

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1,


True), Relation:=1, FormulaText:="1"

SolverOptions 1 ' GRG Nonlinear

result = SolverSolve(UserFinish:=True, ShowRef:=False)

If result = 0 Then

SolverFinish KeepFinal:=1

Else

[Link](failRow, 1).Value = sheetName

failRow = failRow + 1

End If

On Error GoTo 0

Else

[Link](failRow, 1).Value = sheetName & " (invalid P4 or


P6)"

failRow = failRow + 1

End If
End If

Next ws

MsgBox "Solver run complete. Check 'Failed Sheets' for any that were
skipped or failed.", vbInformation

End Sub

Sub DiagnoseSolverFailures()

Dim ws As Worksheet, logWs As Worksheet

Dim skipSheets As Variant

Dim result As Integer

Dim sheetName As String

Dim row As Long

Dim p6Val As Variant, p4Val As Variant

skipSheets = Array("Summary", "Sales", "Sales Input", "Python


Comparison")

' Set up or clear the "Failed Sheets" log

On Error Resume Next

Set logWs = [Link]("Failed Sheets")

If logWs Is Nothing Then

Set logWs = [Link]

[Link] = "Failed Sheets"

Else

[Link]

End If

On Error GoTo 0
' Header

With logWs

.Range("A1:E1").Value = Array("Sheet", "P6 Value", "P6 is Formula",


"P4 is Numeric", "Solver Result")

End With

row = 2

' Loop through sheets

For Each ws In [Link]

sheetName = [Link]

If IsError([Link](sheetName, skipSheets, 0)) Then

p6Val = [Link]("P6").Value

p4Val = [Link]("P4").Value

' Diagnostics

[Link](row, 1).Value = sheetName

[Link](row, 2).Value = p6Val

[Link](row, 3).Value = [Link]("P6").HasFormula

[Link](row, 4).Value = IsNumeric(p4Val)

If IsNumeric(p6Val) And IsNumeric(p4Val) And


[Link]("P6").HasFormula Then

[Link]

SolverReset

SolverOk _

SetCell:=[Link]("P6").Address(True, True, xlA1, True), _

MaxMinVal:=2, _

ByChange:=[Link]("P4").Address(True, True, xlA1, True)


SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1,
True), Relation:=3, FormulaText:="0"

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1,


True), Relation:=1, FormulaText:="1"

SolverOptions 1 ' GRG Nonlinear

result = SolverSolve(UserFinish:=True, ShowRef:=False)

If result = 0 Then

SolverFinish KeepFinal:=1

End If

[Link](row, 5).Value = result

Else

[Link](row, 5).Value = "Skipped"

End If

row = row + 1

End If

Next ws

MsgBox "Diagnostics complete. Check 'Failed Sheets' for details.",


vbInformation

End Sub
Sub DiagnoseSolverFailures()

Dim ws As Worksheet, logWs As Worksheet

Dim skipSheets As Variant

Dim result As Integer

Dim sheetName As String

Dim row As Long

Dim p6Val As Variant, p4Val As Variant

skipSheets = Array("Summary", "Sales", "Sales Input", "Python


Comparison")

' Set up or clear the "Details" log sheet

On Error Resume Next

Set logWs = [Link]("Details")

If logWs Is Nothing Then

Set logWs = [Link]

[Link] = "Details"

Else

[Link]

End If

On Error GoTo 0

' Header

With logWs

.Range("A1:E1").Value = Array("Sheet", "P6 Value", "P6 is Formula",


"P4 is Numeric", "Solver Result")

End With

row = 2
' Loop through sheets

For Each ws In [Link]

sheetName = [Link]

If IsError([Link](sheetName, skipSheets, 0)) Then

p6Val = [Link]("P6").Value

p4Val = [Link]("P4").Value

' Diagnostics

[Link](row, 1).Value = sheetName

[Link](row, 2).Value = IIf(IsNumeric(p6Val), Round(p6Val, 3),


p6Val)

[Link](row, 3).Value = [Link]("P6").HasFormula

[Link](row, 4).Value = IsNumeric(p4Val)

If IsNumeric(p6Val) And IsNumeric(p4Val) And


[Link]("P6").HasFormula Then

[Link]

SolverReset

SolverOk _

SetCell:=[Link]("P6").Address(True, True, xlA1, True), _

MaxMinVal:=2, _

ByChange:=[Link]("P4").Address(True, True, xlA1, True)

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1,


True), Relation:=3, FormulaText:="0"

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1,


True), Relation:=1, FormulaText:="1"
SolverOptions 1 ' GRG Nonlinear

result = SolverSolve(UserFinish:=True, ShowRef:=False)

If result = 0 Then

SolverFinish KeepFinal:=1

End If

[Link](row, 5).Value = result

Else

[Link](row, 5).Value = "Skipped"

End If

row = row + 1

End If

Next ws

MsgBox "Diagnostics complete. Check the 'Details' sheet for results.",


vbInformation

End Sub

Sub Solver()

Dim ws As Worksheet, logWs As Worksheet

Dim skipSheets As Variant

Dim result As Integer

Dim sheetName As String

Dim row As Long


Dim p6Val As Variant, p4Val As Variant

skipSheets = Array("Summary", "Sales", "Sales Input", "Python


Comparison")

' Set up or clear the "Details" log sheet

On Error Resume Next

Set logWs = [Link]("Details")

If logWs Is Nothing Then

Set logWs = [Link]

[Link] = "Details"

Else

[Link]

End If

On Error GoTo 0

' Header

With logWs

.Range("A1:E1").Value = Array("Sheet", "Variable Value", "Objective


is Formula", "Variable is Numeric")

End With

row = 2

' Loop through sheets

For Each ws In [Link]

sheetName = [Link]

If IsError([Link](sheetName, skipSheets, 0)) Then

p6Val = [Link]("P6").Value

p4Val = [Link]("P4").Value
' Diagnostics

[Link](row, 1).Value = sheetName

[Link](row, 2).Value = p6Val

[Link](row, 3).Value = [Link]("P6").HasFormula

[Link](row, 4).Value = IsNumeric(p4Val)

If IsNumeric(p6Val) And IsNumeric(p4Val) And


[Link]("P6").HasFormula Then

[Link]

SolverReset

SolverOk _

SetCell:=[Link]("P6").Address(True, True, xlA1, True), _

MaxMinVal:=2, _

ByChange:=[Link]("P4").Address(True, True, xlA1, True)

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1,


True), Relation:=3, FormulaText:="0"

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1,


True), Relation:=1, FormulaText:="1"

SolverOptions 1 ' GRG Nonlinear

result = SolverSolve(UserFinish:=True, ShowRef:=False)

If result = 0 Then

SolverFinish KeepFinal:=1

End If
End If

row = row + 1

End If

Next ws

MsgBox "Complete. Check the 'Details' sheet for results.",


vbInformation

End Sub

Sub Solver()

Dim ws As Worksheet

Dim skipSheets As Variant

Dim result As Integer

Dim sheetName As String

Dim p6Val As Variant, p4Val As Variant


skipSheets = Array("Summary", "Sales", "Sales Input", "Python
Comparison")

' Loop through sheets

For Each ws In [Link]

sheetName = [Link]

If IsError([Link](sheetName, skipSheets, 0)) Then

p6Val = [Link]("P6").Value

p4Val = [Link]("P4").Value

If IsNumeric(p6Val) And IsNumeric(p4Val) And


[Link]("P6").HasFormula Then

[Link]

SolverReset

SolverOk _

SetCell:=[Link]("P6").Address(True, True, xlA1, True), _

MaxMinVal:=2, _

ByChange:=[Link]("P4").Address(True, True, xlA1, True)

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1,


True), Relation:=3, FormulaText:="0"

SolverAdd CellRef:=[Link]("P4").Address(True, True, xlA1,


True), Relation:=1, FormulaText:="1"

SolverOptions 1 ' GRG Nonlinear

result = SolverSolve(UserFinish:=True, ShowRef:=False)


If result = 0 Then

SolverFinish KeepFinal:=1

End If

End If

End If

Next ws

MsgBox "Solver complete for applicable sheets.", vbInformation

End Sub

CREATE SHEETS

Sub CreateSheetsByUIDFiltered()

Dim srcWS As Worksheet

Dim templateWS As Worksheet

Dim newWS As Worksheet

Dim uidDict As Object

Dim lastRow As Long

Dim i As Long

Dim uid As Variant

Dim destRow As Long

Dim dataRange As Range, cell As Range

Dim tempData As Variant, rowData() As Variant

Dim pasteRow As Long

Set srcWS = [Link]("Sales")

Set templateWS = [Link]("Template")


Set uidDict = CreateObject("[Link]")

[Link] = False

[Link] = False

' Identify last row of data

lastRow = [Link]([Link], "A").End(xlUp).row

' Collect all unique UIDs

For i = 2 To lastRow

uid = Trim([Link](i, 1).Value)

If Len(uid) > 0 Then

If Not [Link](uid) Then

[Link] uid, True

End If

End If

Next i

' Loop through each UID and process

For Each uid In [Link]

' Create or get the sheet for UID

On Error Resume Next

Set newWS = [Link](CStr(uid))

On Error GoTo 0

If newWS Is Nothing Then

[Link]
After:=[Link]([Link])

Set newWS = ActiveSheet


On Error Resume Next

[Link] = Left(CStr(uid), 31)

On Error GoTo 0

Else

Set newWS = [Link](CStr(uid))

End If

' Clear old data from row 9 down in columns A:C

[Link]("A9:C1000").ClearContents

' Collect data for current UID

pasteRow = 9

For i = 2 To lastRow

If Trim([Link](i, 1).Value) = uid Then

[Link](pasteRow, 1).Value = [Link](i, 1).Value ' UID

[Link](pasteRow, 2).Value = [Link](i, 2).Value '


Month

[Link](pasteRow, 3).Value = [Link](i, 3).Value '


Sales

pasteRow = pasteRow + 1

End If

Next i

Set newWS = Nothing

Next uid

[Link] = True

[Link] = True
MsgBox "UID sheets created and populated starting from row 9 in
columns A-C.", vbInformation

End Sub

You might also like