andrewkard1980
Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
Futurism
В Вашем файле небыло матрицы результатов, да ладно, теперь она строится автоматически, пробуйте такой код:
Код: Sub CalcDist()
Dim iCl1%, iCl2%, iRw1%, iRw2%, sNmCl1$, sNmCl2$
Dim lLr%, i%: i = 2
Dim rCl As Range
Dim keysArr(), itemsArr()
Dim oDict: Set oDict = CreateObject("Scripting.Dictionary"): oDict.CompareMode = vbBinaryCompare
If ThisWorkbook.Worksheets.Count < 2 Then
ThisWorkbook.Worksheets.Add After:=Sheets(ActiveWorkbook.Sheets.Count)
ThisWorkbook.Worksheets(1).Activate
End If
For Each rCl In Worksheets(1).UsedRange
If rCl.Value <> "" And oDict.Exists(sUSin) = False Then
oDict.Item(rCl.Value) = i
i = i + 1
End If
Next
With oDict
keysArr = .Keys
itemsArr = .Items
.RemoveAll
End With
With Worksheets(2)
For i = 0 To UBound(keysArr)
.Cells(i + 2, 1).Value = keysArr(i)
.Cells(1, i + 2).Value = keysArr(i)
Next i
End With
With Worksheets(2)
lLr = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To lLr
oDict.Item(.Cells(i, 1).Value) = i
Next i
End With
For iCl1 = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 3 ' íàïðàâî
iCl2 = iCl1 + 3
sNmCl1 = Cells(1, iCl1).Value
sNmCl2 = Cells(1, iCl2).Value
iRw1 = 0: iRw2 = 0
For i = 2 To Cells(Rows.Count, iCl1).End(xlUp).Row
If sNmCl2 = Cells(i, iCl1).Value Then
iRw1 = i
End If
Next i
For i = 2 To Cells(Rows.Count, iCl2).End(xlUp).Row
If sNmCl1 = Cells(i, iCl2).Value Then
iRw2 = i
End If
Next i
If iRw1 <> 0 And iRw2 <> 0 Then
Worksheets(2).Cells(oDict.Item(sNmCl1), oDict.Item(sNmCl2)) = Application.Max(iRw1, iRw2) - Application.Min(iRw1, iRw2)
Else
Worksheets(2).Cells(oDict.Item(sNmCl1), oDict.Item(sNmCl2)).Interior.ColorIndex = 6
End If
Next iCl1
For iCl1 = Cells(1, Columns.Count).End(xlToLeft).Column To 2 Step -3 ' íàëåâî
iCl2 = iCl1 - 3
sNmCl1 = Cells(1, iCl1).Value
sNmCl2 = Cells(1, iCl2).Value
iRw1 = 0: iRw2 = 0
For i = 2 To Cells(Rows.Count, iCl1).End(xlUp).Row
If sNmCl2 = Cells(i, iCl1).Value Then
iRw1 = i
End If
Next i
For i = 2 To Cells(Rows.Count, iCl2).End(xlUp).Row
If sNmCl1 = Cells(i, iCl2).Value Then
iRw2 = i
End If
Next i
If iRw1 <> 0 And iRw2 <> 0 Then
Worksheets(2).Cells(oDict.Item(sNmCl1), oDict.Item(sNmCl2)) = Application.Max(iRw1, iRw2) - Application.Min(iRw1, iRw2)
Else
Worksheets(2).Cells(oDict.Item(sNmCl1), oDict.Item(sNmCl2)).Interior.ColorIndex = 6
End If
Next iCl1
End Sub
|
Добавлено:
hackman
Активности в Excel?
Можно как то так:
Код: Sub BookClose()
Dim i&, lTime&, iSh&, sAdr$
sAdr = ActiveCell.Address
iSh = ActiveSheet.Index
lTime = Timer
Do While Timer > 0
DoEvents
If (Timer - lTime) > 300 Then ' change time (in seconds)
If sAdr = ActiveCell.Address And iSh = ActiveSheet.Index Then
Application.DisplayAlerts = False
ThisWorkbook.Close
Else
sAdr = ActiveCell.Address
iSh = ActiveSheet.Index
lTime = Timer
End If
End If
Loop
End Sub
|
но есть нюансы, макрос можно остановить (Esc+Break, через панель разработчика), есть вероятность, что Timer=0 в момент прохода цикла и макрос остановится, книга закрывается без запроса на сохранение. В общем, доработайте под свои нужды.
Добавлено:
Я запускал его так:
Код:
Private Sub Workbook_Open()
Call BookClose
End Sub
|
Добавлено:
YuriyRR
Через поиск в Google находится практически сразу. |
