andrewkard1980
Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору Futurism Скорее всего такая ошибка может возникнуть, если в словаре нет такой фразы или она пустая. Измените на: For iCl1 = 1 To Cells(1, Columns.Count).End(xlToLeft).Column - 3 Step 3 А по второму, насколько правильно я понял из первого поста и примера, мы ищем верхние фразы в соседних столбцах, если нужно что бы во всех, тогда надо переписывать код. Вчером только смогу глянуть. PS. До мастера еще ой как далеко, организовать пару циклов по алгоритму - это уровень первых шагов.... Добавлено: 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 - 3 Step 3 For iCl2 = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 3 If iCl1 <> iCl2 Then 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 End If Next iCl2 Next iCl1 End Sub |
|