» Excel VBA (часть 2)

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

Есть столбец ячеек с гиперссылками,
Как рядом получить столбец текста (адреса) гиперссылок для всех ячеек (например http://forum.ru-board.com)?

В нете нашел код макроса, который должен это делать, но при его запуске excel выдает ошибку: "Expected: Ens Sub"

Как её исправить?

Сам код:

Sub Макрос1()
Function textH(oCell) As String
Dim s$
On Error GoTo Exit_
s = oCell.Hyperlinks(1).Address
If Len(s) > 0 Then textH = s
Exit_:
End Function
End Sub

Ogeris, убери обрамление из строк


Код: Sub Макрос1()

Доброго всем дня.
Подскажите, можно ли сделать так, чтобы при сохранении файла под другим именем (при помощи макроса) в новом файле не сохранялись макросы исходного.
Код для сохранения файла:
ex_file = path_file + "\RK_003301_" + "m" + num_m + "_" + Right(Str(num_g), 2) + ".xls"
ActiveWorkbook.SaveCopyAs Filename:=ex_file
Переменные path_file, num_m и num_g определяются ранее в этой же процедуре.
Спасибо заранее.

Mitjusha, самый простой вариант - просто создать новую книгу


Код: Dim WB As Workbook, WS As Worksheet
Set WB = Workbooks.Add
For Each WS In ThisWorkbook.Worksheets
WS.Copy WB.Worksheets(1)
Next WS
ex_file = path_file + "\RK_003301_" + "m" + num_m + "_" + Right(Str(num_g), 2) + ".xls"
WB.SaveAs ex_file

ZlydenGL

Да, но при этом в новой книге созданы Лист1, Лист2, ... , Лист1(2), Лист2(2), ...
А как изменить код, чтобы копировался, допустим, только Лист1 и убрать лишние листы с индексами.
Кроме того, у меня на листе исходного файла есть две кнопки, связанные с макросами. Они тоже переносятся в новый файл. Так вот, когда я в новом файле кликаю на них, запускается макрос исходного файла.

Mitjusha, в этом случае не бежишь последовательность For Each WS, а просто делаешь ActiveSheet.Copy. Но вот если для текущего листа определены МАКРОСЫ, то они скопируются в новую книгу

Решение 1:
1. Вынести ВЕСЬ код во внешний модуль
2. После копирования листа пробегать циклом For Each все Embedded Objects и убивать их нафиг.

Решение 2:
Создаем новую книгу, но на первый же активный лист копируем ВЕСЬ использованный диапазон. Правда, явный недостаток - использование буфера обмена.


Код: ActiveSheet.UsedRange.Select
Selection.Copy
Set WB = Workbooks.Add
WB.Activate
WB.ActiveSheet.Range(ThisWorkbook.ActiveSheet.UsedRange.Address).Select
WB.ActiveSheet.Paste
WB.SaveAs...

Как в экселе сделать поиск поля по значению из другого поля ?
Короче на втором листе имеется база данных:


На первом листе в ячейку O нужно вписать значение из листа 2 поля A, найденного по ключевому значению - Login



Сама таблица здесь:
http://ifolder.ru/13112768

YURETS777, дык это даже не программирование Копай в сторону функции VLookUP (на русском - ВПР) Это и будет как раз поиск значения в диапазоне.

Или конкретизируй ТЗ - может ты хочешь, чтобы выбор для ввода на втором листе был выпадающим списком? Тогда тебе в Data - Validation (не знаю, как переводится на русский), выбрать режим Allow - List. И уже в открывшемся поле вводить ограничение (либо перечень через точку с запятой, либо ссылку на диапазон, либо ссылку на именованный диапазон).

Добавлено:
Вот, посмотри - то, что надо?

Ага, вроде оно, только в ВПР есть один недостаток, если оно не находит в таблице всё равно вставляет значение, причем произвольное.
И еще, можно ли потом заменить функцию в первом листе на полученное значение ?

YURETS777, это только если последний аргумент функции - 1! Если указан НУЛЬ - ВПР вернет ЛИБО полное совпадение, ЛИБО ошибку, третьего не дано

Заменить функцию - в смысле скопировать как значение? Можно, почему нет?

Вообще для подобных задач обычно рекомендуется сделать ФОРМУ для ввода данных (ну или макрос как минимум), например, чтобы не хранить во всех колонках формулы, растянутые до строчки 65535 (размер книги будет слоноподобный).

All
кто знает как кликнуть на ссылку след. типа?
<a href="default.aspx#" onclick="Action.LogOut(); return false;">LogOut</a>

Olive77, а подробней можно? В чем косяк, мышка не клацает? Или надо ПРОГРАММНО нажать?

ZlydenGL
естественно, программно.

не совсем ясно, как ее определить через
For Each lnk In ie.Document.Links
В lnk.href будет стоять только "default.aspx#", а там таких ссылок много.

Добавлено
Ах, да.
Пытаюсь обойтись без ссылки на Microsoft HTML Object Library.

Добавлено Ищё
Хотя похоже замкнул.
lnk.OnClick отлично помогает.

Знатоки помогите!
Есть код

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub ' ========galochki
If Not Intersect(Target, Range("A3:A2000")) Is Nothing Then
Target.Font.Name = "arial"
If Target = vbNullString Then
Target = "v"





Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, 9)).Select
Selection.Copy



For i = 2 To 300
If Cells(i, 14) = "" Then Exit For '
Next i
Cells(i, 14).Select
ActiveSheet.Paste
Else

Target = vbNullString

End If
End If


End Sub ' ========galochki





кода "А1" активирую, (галочка получается V)то Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, 9)).Select строку копирует и в Cells(i, 14).Select ActiveSheet.Paste ставит
Вопрос : А как сделать так, когда галочку убираю, то, что бы данная строка, то же исчезлаCells(i, 14).

Я на Вы с VBA может не так объяснил
И еще. Есть какой нибудь таймер, что бы на пол секунду задержать работу макроса?
Этот код, я сам написал как мог. Может есть более интересные варианты?

Добавлено:
Еще вопрос если можно
есть такой код

Sub Ra()
Dim Shtuki As Integer
Dim i As Integer
Dim j As Integer
i = 2
Do While i < ActiveSheet.Range("A65536").End(xlUp).Row + 1
Shtuki = Cells(i, 2)
If Shtuki > 1 Then
Cells(i, 2) = 1
For j = 1 To Shtuki - 1
Rows(i + 1).Select
Selection.Insert Shift:=xlDown
Range(Cells(i, 1), Cells(i, 3)).Copy Cells(i + 1, 1)
Next j
End If
i = i + 1
Loop
End Su


то есть

обувь 3 1000 руб шт после обработки кода
обувь 1 1000 руб шт
обувь 1 1000 руб шт
обувь 1 1000 руб шт


а надо, что бы наоборот работал
обувь 1 1000 руб шт
обувь 1 1000 руб шт
обувь 1 1000 руб шт

обувь 3 1000 руб шт после обработки кода

Заранее Спасибо!

maratino
По 1-му вопросу:
Искать и удалять значения ранее вставленных строк, по большому счету невозможно, т.к. если предположить, что есть строки с одинаковыми значениями в столбцах со 2-го по 9-й. Поэтому, предлагаю, в предварительно скрытый столбец (в примере это столбец № 22) при вставке данных, заносить номер выбранной строки. Затем, при удалении искать в этом столбце номер (что проще и корректнее) и удалять именно эти значения. Примерно так:

Код: Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long, x As Range
If Target.Cells.Count > 1 Or Intersect(Target, Range("A3:A2000")) Is Nothing Then Exit Sub
Target.Font.Name = "Marlett": Columns(1).HorizontalAlignment = xlCenter
If Target = "a" Then
Target.ClearContents
Set x = Columns(22).Find(Target.Row, LookAt:=xlWhole)
If Not x Is Nothing Then Range(Cells(x.Row, 14), Cells(x.Row, 22)).Delete Shift:=xlUp
Else
Target = "a": i = Cells(Rows.Count, 14).End(xlUp).Row + 1
Range(Cells(Target.Row, 2), Cells(Target.Row, 9)).Copy Cells(i, 14): Cells(i, 22) = Target.Row
End If
End Sub

SAS888 Спасибо !
По второму вопросу. Работает, но каличество не считает. Только нули
Может я вопрос не так сформулировал

а надо, что бы наоборот работал
обувь 1 шт 1 000 руб
обувь 1 шт 1000 руб
обувь 1 шт 1000 руб

итог
обувь 3 шт 3000 руб так правильнее будет

Я склад-магазин программу слепил. Все это для более удобной работы

А первый вариант, вряд ли. Надо так. Галочку ставим, артикул появляется в торг. отчете,
(а дальше в счет-фактуру) Убираем галочку, с торга этот артикул исчезает, и пустая
ячейка тоже удаляется

А так, все работает. Удобно. Все видно. Не надо заморачиватся так, как в 1с

Цитата:

Работает, но каличество не считает

Конечно, не считает. Перед строкой
Код: Cells(i - 1, 2) = Cells(i, 2) + Cells(i - 1, 2): Rows(i).Delete

Добрый день. Написал вопрос в разделе Excel FAQ, но мне порекомендовали обратиться сюда. Обращаюсь)))
Вопрос:


Добрый день, народ помогите!!!
Случай не очень тяжелый, но может кто поможет.
Есть таблица, на рисунки видно два стоблца ФИО и МЕСТО РАБОТЫ, всегда постоянны. Задача из столбца "МЕСТО РАБОТЫ" вытащить слово и вставить его в столбец "ПОИСК" а в столбце "№" подсчитать сколько раз именно такого слово встерчалась в столбце "МЕСТО РАБОТЫ". НО главная цель не искать и сравнивать ячейки, а именно слова из ячеек. кто поможет? очень надо..

Вот что в том разделе порекомендовали:

Цитата:

я бы рекомендовал в данном случае сделать через макрос на VBA (с этим вопросом лучше сюда - Excel VBA [?]
в макросе парсить строчку на слова, слова записывать...
Количество вхождений - можно (лучше) сделать через формулу...

примечания.
1) четвёртый столбец лучше назвать не "№" - а "Количество вхождений"
2) для слова "Компания" количество вхождения должно быть 2

Готов принять любую помощь!

ZlydenGL

Цитата:

Код:Sub Макрос1()

и

Код:End Sub


И не забудь, что функции, вызываемые на листах Ёкселя, должны находиться в МОДУЛЯХ, а не в коде соотетствующих листов (или глобальной книги).

Удачи!

Чувствую себя блондинкой ((((((

1) Если убрать название Sub Макрос1(), то этот макрос не появляется в списке макросов, как тогда его запустить?
2) Как понять, что вызываемая функция находится в модулях?

SAS888
мне кажется, я что то не так делаю
я такое слепил. Работает

Sub Value_Count()

Dim ir As Long
Dim iSource As Range
iLastCell = Cells(1, 1).SpecialCells(xlLastCell).Row
Set iSource = Range(Cells(1, 1), Cells(iLastCell, 1))
ir = 1
For Each Cell In iSource
iText = Cells(ir, 1).Value
iCount = Application.WorksheetFunction.CountIf(iSource, iText)
Cells(ir, 2).Value = iCount
ir = ir + 1
Next



Columns("A:b").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
k = 1
i = 2
While i <= ActiveCell.CurrentRegion.Rows.Count
If Cells(k, 1) = Cells(i, 1) Then
Cells(i, 1).EntireRow.Delete
Else
k = k + 1
i = i + 1
End If
Wend

End Sub

Люди, не поможете?
Есть хороший набор макросов WOPR 2003, который при установке на Office 2003 SP3 выдаёт ошибку "Требуемый класс отсутствует в Class Factory.Out of memory".

Образ диска с установочным файлом находится тут. Установщик программы запускается с жёсткого диска только при наличии смонтированного в виртуальном устройстве данного образа. Прожигать не обязательно.
В этом наборе макросов очень много полезных фич, рассчитываю, что местные гуру мне помогут. Уверен,что дело в каком- нибудь пустячке.Спасибо!

GameKowal
тут искал?
http://forum.ru-board.com/topic.cgi?forum=35&topic=8094&start=40#lt

зы ты оттуда пришел

maratino

Цитата:

мне кажется, я что то не так делаю
я такое слепил. Работает

А что? Так не работает?

Код: Sub Main()
Dim i As Long: Application.ScreenUpdating = False
ActiveSheet.UsedRange.Sort Key1:=[A1], Order1:=xlAscending, Header:=xlGuess
For i = Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
If Cells(i, 1) = Cells(i - 1, 1) Then
Cells(i - 1, 3) = Cells(i, 3) + Cells(i - 1, 3): Cells(i - 1, 2) = Cells(i, 2) + Cells(i - 1, 2)
Rows(i).Delete
End If
Next
End Sub

Troll
Предлагаю один из вариантов решения. Формул на листе не требуется. Все делается макросом. Контролируются все строки в столбце 2, уникальные слова заносятся в столбец 3. В столбце 4 - количество данных слов в столбце 2.

Код: Sub Main()
Dim i As Long, j As Long, x As New Collection, txt As String, a: Application.ScreenUpdating = False
Range([C2], Cells(ActiveSheet.UsedRange.Rows.Count, 4)).ClearContents
For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row
a = Split(Cells(i, 2), " "): On Error Resume Next
For j = LBound(a) To UBound(a)
x.Add a(j), CStr(a(j)): txt = txt & " " & a(j)
Next
On Error GoTo 0
Next
a = Split(txt, " ")
For i = 1 To x.Count
Cells(i + 1, 3) = x(i): Cells(i + 1, 4) = UBound(Filter(a, x(i))) + 1
Next
End Sub

SAS888, извините, я позволю себе сделать маленькую попровочку...
дело в том, что этот код одно и то же слово в разных регистрах добавляет один раз (так работает добавление в коллекцию x.Add)
но при подсчёте регистр влияет. получается, если слово написано в разных регистрах, то в подсчёте учитывается только количество ПЕРВОГО НАПИСАНИЯ слова.
Это легко подправить — позволю себе предложить такой код подсчёта количества вхождений вместо Вашего:

Код:
a = Split(UCase(txt), " ")
For i = 1 To x.Count
Cells(i + 1, 3) = x(i): Cells(i + 1, 4) = UBound(Filter(a, UCase(x(i)))) + 1
Next

прошу помощи
в макросе
значеня берутся из диапозона столбца и записываются в одну ячейку
пример
все значения из A1:A20 записываются через запятую B1
из A21:A40 записываются через запятую B2
и так далее шаг для выборки значений из диапозона 20
шаг для итоговой ячейки 1
формат ячеек текст

DenisSmo, а в чем собственно помощь-то нужна? В написании этого макроса? Или уже есть макрос, но с ним есть проблемы? В первом случае - прочитайте заголовок шапки Во втором - рассекретьте код макроса

SERGE_BLIZNUK
1. Абсолютно согласен с регистрами. Дело в том, что когда писал код, думал использовать текстовое сравнение (vbTextCompare), где регистр значения не имеет. Но затем сделал по другому. А в этом случае, действительно, нужно преобразовывать к одному регистру.
2. По поводу UBound(Filter(a, слово)). Функция Filter(a, слово) возвращает одномерный массив из элементов массива a, в кторые входит слово (есть еще ряд параметров, которые в данном случае используются по умолчанию). Соответственно, размерность полученного массива и будет количеством вхождений (по умолчанию, размерность начинается с "0").

собственно, в написании макроса