» Excel VBA (часть 3)

cfyrjcj
Да, его нужно полностью скопировать и вставить в Модуль в Редакторе VBA, потом запустить (Alt+F8 либо Макросы, выбираете нужный, запускаете).
Далее макрос спросит - содержимое ячейки, столбец которой надо удалить. Если таких ячеек будет несколько - все такие столбцы будут удалены.

ошибся. удалил

Есть файл с данными. Задача такая надо высчитать расстояние для совстречающихся понятий.
Что это значит. В файле
http://rghost.ru/5717220
Смотрите вот в столбце есть фраза продвижение сайта в поисковых системах
, от нее до фразы seo продвижение 5 строчек(шагов). В свою очередь. если мы дойдем до столбца seo продвижение это столбец до фразы продвижение сайта в поисковых системах 8 шагов.
В этой ситуации мы из большего отнимаем меньшее 8 шагов минус 5 =3. т.е. по сути y6-v9.
Там все слова уникальны.
Можно ли провести "вычитание" этих слов из каждых столбцов.

Futurism
Пробуйте:

Код:
Sub CalcDist()
Dim iCl1%, iCl2%, iRw1%, iRw2%, sNmCl1$, sNmCl2$
Dim i%, iRw%: iRw = 2

If ThisWorkbook.Worksheets.Count < 2 Then
ThisWorkbook.Worksheets.Add After:=Sheets(ActiveWorkbook.Sheets.Count)
ThisWorkbook.Worksheets(1).Activate
End If

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(iRw, 1) = sNmCl1 & " vs " & sNmCl2
Worksheets(2).Cells(iRw, 2) = Application.Max(iRw1, iRw2) - Application.Min(iRw1, iRw2)
iRw = iRw + 1
End If
Next iCl1

For iCl1 = Cells(1, Columns.Count).End(xlToLeft).Column - 1 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(iRw, 1) = sNmCl1 & " vs " & sNmCl2
Worksheets(2).Cells(iRw, 2) = Application.Max(iRw1, iRw2) - Application.Min(iRw1, iRw2)
iRw = iRw + 1
End If
Next iCl1
End Sub

andrewkard1980
прекрасно сделали, профессиональная работа. Все ок. Единственная просьба, а можно сделать, чтобы все результаты "вычитания" были в форме симметричной матрицы.
например так
http://rghost.ru/57183673
т.е. тут понятно ноль значит фраза встречается сама с собой. желтенькой я пометил значит пустой сектор, ну и разность шагов между переменными. 3-ка это как помните 8-5.

Futurism
Пробуйте:
http://rghost.ru/57226928

Более красивее наверное придумать нельзя. Очень удобно сделали. А макрос будет работать, если:
1. я добавлю ещё столбцы со фразами
2 я пустые столбцы, вы же видели, что там фразы идут через 2 столбца, так вот их удалю?

Futurism
1) Добавить столбцы можно, будет работать, добавлятьтолько их нужно на оба листа.
2) Удалить так же можно, но нужно будет изменить шаг в макросе:

For iCl1 = 1 To Cells(1, Columns.Count).End(xlToLeft).Column - 3 Step 3
iCl2 = iCl1 + 3

For iCl1 = Cells(1, Columns.Count).End(xlToLeft).Column - 1 To 2 Step -3
iCl2 = iCl1 - 3

у меня что то не получается. он пишет ошибку. это такой же документ, но с другой тематикой для анализа
http://rusfolder.com/41362820
т.е. как на 2 листа

ссылки на список соответствия имен функций в английской и русской версиях Excel из шапки умерли (. У кого сохранился переложите, плиз.

Futurism
надо матрицу сделать на втором листе, тогда должен сработать. При чем матрица должна содержать все возможные варианты.

andrewkard1980
у меня на работает. может вы глянете в этом файле
http://rusfolder.com/41362820

Ребята подскажите...
Нужно автоматически закривать Excel файл при неактивности пользователя 5 минут. Как определить факт простоя?

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 ' &#237;&#224;&#239;&#240;&#224;&#226;&#238;
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 ' &#237;&#224;&#235;&#229;&#226;&#238;
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

andrewkard1980
бесспорно, вы мастер ВБА, я снимаю шляпу.
Однако, есть некоторые неточности, до простите Вы их мне
1. стал запускать макрос выдалась ошибка
1004
скрин

2. мне кажется какие-то шажки он таки не высчитывает.
смотрите. откройте лист1
http://rghost.ru/57304973
смотрим столбец А-от фразы ремонт компьютеров до фразы ремонт телефонов 11 шагов. Теперь идем в столбец AH ремонт телефонов. от этой фразы до фразы ремонт компьютеров 13 шагов
13-11=2 теперь смотрим в лист 2 в матрице этот файл
смотрим ячейку M2 , там цифра 2 не стоит. Я ещё видел пару совстречающихся фраз, которые не были посчитаны.
Можете, пожалуйста, проверить ваш алгоритм. может что-то он не так высчитывает.

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

во с вашим последним кодом в самый раз.

Futurism
Закоментируйте строку:
Worksheets(2).Cells(oDict.Item(sNmCl1), oDict.Item(sNmCl2)).Interior.ColorIndex = 6

ок, а что насчет графа. я только что попросил выше)

Добавлено:
Такой вопросик. Один мой знакомый написал вба код, который рисует корр.плеяды по полученной корреляционной матрице.
выглядит это примерно так

но там код сложный, он рисует плеяды только с коэф.которые стат. достоверно коррелируют между собой.
а можно сделать, чтобы рисовался такой граф, но по полученным результатам, причем чем длиннее шаг тем длиннее линия.

Добавлено:

Цитата:

PS. До мастера еще ой как далеко, организовать пару циклов по алгоритму - это уровень первых шагов....

у меня и такого уровня нет.

<B>andrewkard1980</B>
Макрос работает, но тогда не работают остальные макросы книги.(

Futurism
пример нарисуйте

Добавлено:
hackman
проверил, другие макросы работают, пробуйте:
http://rghost.ru/57315457

пример в пэинте состряпал

нолики приравняйте к единичкам. это не критично

Добрый день.
Пытаюсь немного переделать найденный в инете макрос на очищение ячеек ( в указанном диапазоне очищаются ячейки, значение которых равно 16, 17, 18):

Код: Sub Macros()
For Each cell In [h16:I25]
If cell.Value = 16 Or cell.Value = 17 Or cell.Value = 18 Then cell.Value = ""
Next
End Sub

Leojse попробуй заменить на объект Range, тогда после указания начальной позиции можно будет работать со столбцами/колоннами в относительном виде
Код: Sub Macros()
Dim a As Range
Set a = Range("H16")
For Each cell In a.Range(Cells(1, 1), Cells(8, 2))
If cell.Value = 16 Or cell.Value = 17 Or cell.Value = 18 Then cell.Value = ""
Next
End Sub

vikkiv, спасибо за внимание! Но я, скорее всего, не так выразился.
Как задать "от" и "до" значений, которые надо удалить? То есть не писать

Код: If cell.Value = 16 Or cell.Value = 17 Or cell.Value = 18 Then cell.Value = ""

Leojse
Код: If cell.Value >= 16 And cell.Value <= 18 Then

vikkiv, спасибо огромное!

Leojse
Можно так:

Код:
Sub Macros()
For Each cell In [h16:I25]
Select Case cell.Value
Case 16 To 18
cell.Value = ""
End Select
Next
End Sub

andrewkard1980, и Вам спасибо! Теперь аж два варианта будет)

Да, Select Case наверное решение получше т.к. удобнее работает и с произвольными списками например можно
Код: ...
Case 16 To 18, 11, 22 To 27, 30
...