andrewkard1980
Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору Fsp050 Чуть исправил, ед. на что надо обращать внимание, это на размерность массива для вывода результатов (к-во красных ячеек), пока поставил на 100 шт. Код: Sub test() Dim i&, l&, x&, y&, z&, s$, s1$, s2$, a(1 To 100, 1 To 3) 'до 100 красных ячеек Dim key, item Dim oDict: Set oDict = CreateObject("Scripting.Dictionary"): oDict.CompareMode = vbBinaryCompare x = 1: y = 1: z = 1 For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row For l = 2 To Cells(1, Columns.Count).End(xlToLeft).Column If Cells(i, l).Font.ColorIndex = 3 Then s1 = Cells(i, 1).Value If oDict.Exists(s1) = True Then Else oDict.item(s1) = x x = x + 1 End If s2 = Cells(1, l).Value If oDict.Exists(s2) = True Then Else oDict.item(s2) = x x = x + 1 End If a(y, 1) = s1 a(y, 2) = s2 a(y, 3) = Cells(i, l).Value y = y + 1 End If Next l Next i key = oDict.Keys item = oDict.Items If oDict.Count > 4 Then s = "*Vertices 100500" Else s = "*Vertices " & oDict.Count Open "D:\\file.txt" For Append As #1 Print #1, s For i = 0 To UBound(key) Print #1, (item(i) & " " & key(i)) Next i Print #1, "" Print #1, "*Edges" For i = 1 To 100 'до 100 красных ячеек Print #1, (oDict.item(a(i, 1)) & " " & oDict.item(a(i, 2)) & " " & a(i, 3)) Next i Close #1 End Sub |
|