Как в Word найти седловые точки матриц — теория игр

[Sasha_Smirnov]

Здравствуйте, уважаемые юные таланты и закоренелые профи.

За 11 лет я впервые, в прошедшие выходные, применил в VBA ссылки на объект (в объявлениях переменных).

Спешу разделить свой успех со всеми интересующимися работой с Word.

(Вот определение седловых точек, а вот более узкоспецильный форум — кто хочет попробовать то же самое на другом языке.)

В приложенном файле программа запускается по альт-шифт-s. Её текст можно посмотреть там по альт-F11. Попробуйте также альт-F9 (посмотреть коды полей, вставленных через Вид→Ссылка...→Название, — это для меня тоже ноу-хау!).

Дробные числа в матрицах воспринимаются программой в зависимости от национальных настроек Windows (или что там у вас...). Думаю вот, как этот разнобой (десятичная точка либо десятичная запятая) побороть.

P/s: к сожалению, настройки безопасности подозрительно относятся к открытию моего документа (как и вообще макросов). Это я заметил только что на другом компьютере. Потому и даю ниже непосредственно код, несколько урезанный — а то не влез!

[Sasha_Smirnov]

Sub SaddlePoints() 'находит в матрицах (в виде таблиц Word) "седловые точки" (минимаксы) и красит их

Dim lastRow As Byte, lastCol As Byte, tableNumber As Byte, rowMin, colMax, tmpMin, tmpMax, i, j, k, i_2
Dim CurrentRow As Row                   'задали переменную (объект Row) для текущей строки
Dim CurrentCol As Column                'задали переменную (объект Column) для текущего стoлбца
Static answer As Integer


With ActiveDocument.Tables
For tableNumber = 1 To .Count               'перебираем таблицы (если они есть)

lastRow = .Item(tableNumber).Rows.Count
lastCol = .Item(tableNumber).Columns.Count
If lastRow < 2 Or lastCol < 2 Then GoTo NextTable

ReDim jMinOfTheRow(lastCol) As Boolean  'массив признаков минимальных в строке элементов
ReDim iMaxOfTheCol(lastRow) As Boolean  'массив признаков максимальных в колонке элементов

'MsgBox "tableNumber = " & tableNumber & vbLf & "lastRow = " & lastRow & vbLf & "lastCol = " & lastCol

For i = 1 To lastRow
    Set CurrentRow = .Item(tableNumber).Rows(i)
    
    jMinOfTheRow(1) = True          'cначала считаем, что минимальный элемент i-й строки - это 1-й'
    CurrentRow.Cells(1).Select      'выделяем (в строке i) 1-ю ячейку'
    rowMin = Selection.Calculate
    tmpMin = rowMin                 'сохраняем - для последующего сравнения с другими'
    
        For j = 1 To lastCol - 1
'            MsgBox "jMinOfTheRow(" & j & ") = " & jMinOfTheRow(j) & vbCr & vbCr & _
            "*** Элемент [" & i & ", " & j & "] = " & Selection.Calculate & ". ***" 'отладочный MsgBox
        
            CurrentRow.Cells(j + 1).Select
            rowMin = Selection.Calculate        'новый кандидат на минимум в строке i
            
                If rowMin < tmpMin Then
                    For k = 1 To j: jMinOfTheRow(k) = False: Next 'стираем прежние метки минимумов
                    jMinOfTheRow(j + 1) = True
                    tmpMin = rowMin
                ElseIf rowMin = tmpMin Then
                    jMinOfTheRow(j + 1) = True  'включаем элемент, равный минимальному, в их группу'
                End If
        Next j
        
'        MsgBox "jMinOfTheRow(" & lastCol & ") = " & jMinOfTheRow(lastCol) & vbCr & vbCr & _
        "*** Элемент [" & i & ", " & lastCol & "] = " & Selection.Calculate & ". ***" 'отладочный MsgBox
    'На данный момент - отмечены все минимальные элементы i-й строки (в таблице номер tableNumber).

        
    For j = 1 To lastCol    'перебираем все элементы строки i - на предмет совпадений min по j и max по i
        For k = 1 To lastRow: iMaxOfTheCol(k) = False: Next 'очищаем все метки максимумов для столбца j'
        If jMinOfTheRow(j) Then 'если j - индекс столбца, где есть минимальный элемент строки, идём дальше
        
            Set CurrentCol = .Item(tableNumber).Columns(j) 'исследуем этот (j-й) столбец матрицы
            
            iMaxOfTheCol(1) = True      'cначала считаем, что максимальный элемент j-го столбца - это 1-й
            CurrentCol.Cells(1).Select
            colMax = Selection.Calculate
            tmpMax = colMax                 'сохраняем - для последующего сравнения с другими
            
            For i_2 = 1 To lastRow - 1
                CurrentCol.Cells(i_2 + 1).Select
                colMax = Selection.Calculate            'новый кандидат на максимум в колонке j
                
                    If colMax > tmpMax Then
                        For k = 1 To i_2: iMaxOfTheCol(k) = False: Next 'стираем прежние метки максимумов
                        iMaxOfTheCol(i_2 + 1) = True
                        tmpMax = colMax
                    ElseIf colMax = tmpMax Then
                        iMaxOfTheCol(i_2 + 1) = True 'включаем элемент, равный максимальному, в их группу'
                    End If
            Next i_2
            
            If iMaxOfTheCol(i) = True Then      'Это значит, что в строке i - на пересечении с колонкой j -
                                                'находится (очередной) седловой элемент матрицы tableNumber'
            .Item(tableNumber).Cell(i, j).Select
            With Selection.Font: .ColorIndex = wdGreen: .Bold = Not .Bold: End With         'КРАСИМ "СЕДЛО"'
            End If
        'для элемента j-го столбца (содержащего минимум i-й строки) выяснили: он максимальный в столбце?
        End If
    Next j
    
    For k = 1 To lastCol: jMinOfTheRow(k) = False: Next 'очищаем все метки минимумов для строки i'
Next i

NextTable:
Next tableNumber

If .Count = 0 Then MsgBox "В документе " & Chr$(171) & .Parent & Chr$(187) & " нет таблиц Word. Пока."
End With


If answer <> vbCancel Then
    answer = MsgBox("Очистить формат?" & _
    vbLf & vbLf & "Жмите «Отмена» (Cancel), чтобы не отвечать на этот вопрос.", vbQuestion + vbYesNoCancel)
End If
If answer = vbYes Then With ActiveDocument.Range: .Font.ColorIndex = wdAuto: .Bold = Not .Bold: End With

End Sub

[Sazary]

Интересно