Excel VBA 使用 Excel 求解器循环，根据某些不同的单元格值复制单元格值

Question

我是 VBA 的新手，正在尝试实现 Excel 求解器循环。到目前为止，我还没有找到解决我的具体问题的方法，所以我希望能在这里得到一些帮助。

所以我正在做的是：

使用求解器最小化 objective 单元格（在本例中为 B16）
根据需要多次更改单元格值 (C2)，直到求解器解决方案发生变化（值变大或变小，具体取决于 E8 的值，可以是 1 或 0）
将此单元格值复制到预定义单元格（F8 或 G8，具体取决于
E8 的值，可以是 1 或 0)
将单元格值 (C2) 更改为其开头的起始值
切换到下一个单元格 (C3) 并更改单元格值直到解决方案更改
将此单元格值复制到预定义单元格（F9 或 G9，具体取决于
E9 的值，可以是 1 或 0)

因此，在第 4 步之前，它工作完美，但仅适用于那个单元格。我希望现在有可能逐个单元地进行下去。因此，我通过实现 i 来计算行数来尝试它，但总是得到默认消息。

所以这是我的代码：

Sub Makro6()
Dim rng As Range, cell As Range
Set rng = Range("C2")

If Range("E8").Value = 1 Then

Do
    For Each cell In rng
    cell.Value = cell.Value + 1
    Next cell

    SolverOk SetCell:="$B", MaxMinVal:=2, ValueOf:=0, ByChange:="$C:$E", _
    Engine:=2, EngineDesc:="Simplex LP"
    SolverOk SetCell:="$B", MaxMinVal:=2, ValueOf:=0, ByChange:="$C:$E", _
    Engine:=2, EngineDesc:="Simplex LP"
    SolverSolve True

Loop Until Range("E8").Value = 0

   'Copying cell Value, when Solver solution switched in certain cell depending if it before was 1 or 0
   Range("C2").Select
   Selection.Copy
   Range("F8").Select
   ActiveSheet.Paste

   'Copying start value back into cell after solver loop
   Range("B2").Select
   Selection.Copy
   Range("C2").Select
   ActiveSheet.Paste

Else

Do
    For Each cell In rng
    cell.Value = cell.Value - 1
    Next cell

    SolverOk SetCell:="$B", MaxMinVal:=2, ValueOf:=0, ByChange:="$C:$E", _
    Engine:=2, EngineDesc:="Simplex LP"
    SolverOk SetCell:="$B", MaxMinVal:=2, ValueOf:=0, ByChange:="$C:$E", _
    Engine:=2, EngineDesc:="Simplex LP"
    SolverSolve True

Loop Until Range("E8").Value = 1

   'Copying cell Value, when Solver solution switched in certain cell depending if it before was 1 or 0
   Range("C2").Select
   Selection.Copy
   Range("G8").Select
   ActiveSheet.Paste

   'Copying start value back into cell after solver loop
   Range("B2").Select
   Selection.Copy
   Range("C2").Select
   ActiveSheet.Paste

End If

End Sub

非常感谢您的帮助:)

Answer 1

我想你正在寻找这样的东西。

ActiveCell.Offset(1,0).Select

请记住，它始终是（行，列），因此如果您在单元格 C3 中，上面的代码将移动到 C4。如果你在单元格 C3 中并且你想移动到 D3，你会这样做。

ActiveCell.Offset(0,1).Select

Answer 2

好的，试一试。它应该适用于 C2 和 C3，但可以通过更改定义 rng

的行来扩展到你喜欢的程度

Sub Makro6()

Dim rng As Range, cell As Range

Set rng = Range("C2:C3")

For Each cell In rng
    If cell.Offset(6, 2).Value = 1 Then
        Do
            cell.Value = cell.Value + 1
            SolverOk SetCell:="$B", MaxMinVal:=2, ValueOf:=0, ByChange:="$C:$E", _
            Engine:=2, EngineDesc:="Simplex LP"
            SolverOk SetCell:="$B", MaxMinVal:=2, ValueOf:=0, ByChange:="$C:$E", _
            Engine:=2, EngineDesc:="Simplex LP"
            SolverSolve True
        Loop Until cell.Offset(6, 2).Value = 0
            'Copying cell Value, when Solver solution switched in certain cell depending if it before was 1 or 0
            cell.Copy cell.Offset(6, 3)
            'Copying start value back into cell after solver loop
            cell.Offset(, -1).Copy cell
    Else
        Do
           cell.Value = cell.Value - 1
           SolverOk SetCell:="$B", MaxMinVal:=2, ValueOf:=0, ByChange:="$C:$E", _
           Engine:=2, EngineDesc:="Simplex LP"
           SolverOk SetCell:="$B", MaxMinVal:=2, ValueOf:=0, ByChange:="$C:$E", _
           Engine:=2, EngineDesc:="Simplex LP"
           SolverSolve True
        Loop Until cell.Offset(6, 2).Value = 1
            'Copying cell Value, when Solver solution switched in certain cell depending if it before was 1 or 0
            cell.Copy cell.Offset(6, 4)
            'Copying start value back into cell after solver loop
            cell.Offset(, -1).Copy cell
    End If
Next cell

End Sub

Excel VBA 使用 Excel 求解器循环，根据某些不同的单元格值复制单元格值

Excel VBA Loop with Excel Solver with copying cell value depending on certain different cell value

excel

vba

loops

solver