» Excel VBA (часть 2)

DenisSmo
Если "в лоб", то можно так:

Код: Sub Main()
Dim i As Long, j As Long: Application.ScreenUpdating = False: j = 1
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
Cells(j, 2) = Cells(j, 2) & ", " & Cells(i, 1)
If i Mod 20 = 0 Then
If Cells(j, 2) <> "" Then Cells(j, 2) = Right(Cells(j, 2), Len(Cells(j, 2)) - 2)
j = j + 1
End If
Next
If Cells(j, 2) <> "" Then Cells(j, 2) = Right(Cells(j, 2), Len(Cells(j, 2)) - 2)
End Sub

DenisSmo
да... за SAS888 не угонишься... :):):)

ну, и я в "лоб" решил.. и, чтобы код зря не пропадал, привожу его здесь:

Код:
Sub Main()
Dim i%, LastRow%
' для столбца B зададим текстовый формат
Columns("B:B").NumberFormat = "@"
' сотрём всё, что есть в столбце B
Columns("B:B").ClearContents
' последняя заполненная строка по столбцу A
LastRow = Cells(ActiveWorkbook.ActiveSheet.UsedRange.Rows.Count + 1, "A").End(xlUp).Row
For i = 1 To LastRow
If (i Mod 20) = 1 Then
Cells(((i - 1) \ 20) + 1, "B").Value = CStr(Cells(i, "A"))
Else
Cells(((i - 1) \ 20) + 1, "B").Value = CStr(Cells(((i - 1) \ 20) + 1, "B")) & "," & CStr(Cells(i, "A"))
End If
Next i
End Sub

Имеется макрос, который находит две одинаковые строки и одну удаляет, а надо, чтобы все одинаковые строки удалял.
Sub ()
'
' Dim Start As Long, Finish As Long, col As Long
Start = 1: col = 1
Application.ScreenUpdating = False
With ActiveSheet
Finish = .Cells(.Rows.Count, col).End(xlUp).Row
Set rng = .Range(.Cells(Start, col), .Cells(Finish, col))
For i = Finish To Start Step -1
If Application.CountIf(rng, Cells(i, col)) = 2 Then Rows(i).Delete
Next i
End With
Application.ScreenUpdating = True
'

'
End Sub

Понимаю, что нужно здесь поменять Then Rows(i).Delete, но не получается.

PETKINA

это не так просто, как могло бы показаться.
Дело в том, что Ваш макрос удаляет повторяющуюся ячейку даже в том случае, если они расположены "вразнобой" (т.е. НЕ ПОДРЯД). Поэтому, я лично вижу двухпроходный алгоритм - первый раз собираем все значения, которые надо удалять (хотя бы в ту же Dim x As Collection через x.Add(удаляемое_значение)
а на втором проходе: либо цикл по всем строками и сравнивать значение текущего элемента в коллекции, и, если совпал - удалять строку,
либо цикл по элементам коллекции - тогда надо искать нужную строку через функцию поиска значения и удалять найденную строчку.
1-й вариант потребует минимальных переделок исходного кода.


NB. А Вы знаете, что Вам макрос:
1) проверяет совпадение только исключительно в столбце A (остальные столбцы могут отличать как угодно, макрос "смотрит" только значение первого столбца)?!
2) удаляются строго ДВОЙНЫЕ записи, если дублирующихся значений три и более, то они все остаются.... Это баг или фича?! :)

PETKINA
Замечания от SERGE_BLIZNUK, как всегда неоспоримы. Мне задача тоже показалась интересной. Предлагаю вариант (в один проход!!!), который не имеет указанных недостатков.

Код: Sub DeleteRows()
Dim x As Range, Lr As Long, i As Long: Application.ScreenUpdating = False: i = 1
Do
Lr = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
On Error GoTo Ext
Set x = Intersect(Rows(i & ":" & Lr).ColumnDifferences(Cells(i, 1)).EntireRow, Cells)
If x.Rows.Count < Lr - i Then
x.Copy Rows(Lr + 1): Rows(i & ":" & Lr).Delete
Else: i = i + 1
End If
Loop
Ext: End Sub

SAS888, СУПЕР!!!! НО, КАК?! Расскажите, КАК это работает?! я в шоке.. :)

Предлагаю тот же [more=Код]
Код: Sub DeleteRows()

'Определяем переменные, запрещаем обновление экрана, присваиваем переменной i
'номер начальной строки (i = 1)

Dim x As Range, Lr As Long, i As Long: Application.ScreenUpdating = False: i = 1

'Организовываем бесконечный цикл. Условие выхода из которого проверяем в теле цикла

Do

'Определяем последнюю использованную строку на листе

Lr = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1

'Если следующая строка приводит к ошибке (кончились строки), выход из процедуры.

On Error GoTo Ext

'Выбираем диапазон строк с i-й до последней, состоящий из несовпадающих строк со строкой i

Set x = Intersect(Rows(i & ":" & Lr).ColumnDifferences(Cells(i, 1)).EntireRow, Cells)

'Если количество строк в этом диапазоне больше 1 (т.е. есть совпадение строк), то все несовпадающие строки
'копируем ниже использованных строк листа (отсюда и ограничение о котором я говорил), затем оставляем
'только неисследованный диапазон (скопированные строки). Если же нет совпадений, то оставляем текущую строку
'в покое и в дальнейшем рассматриваем диапазон, начиная со следующей строки (i = i + 1)

If x.Rows.Count < Lr - i Then
x.Copy Rows(Lr + 1): Rows(i & ":" & Lr).Delete
Else: i = i + 1
End If
Loop
Ext: End Sub

Как из макроса


Цитата:

Sub Достать_гиперссылку()
ActiveCell.Offset(0, 1) = ActiveCell.Hyperlinks(1).Address
End Sub

Сделать функцию?

Ogeris, примерно так:


Код: Function GetHyperLink(Source)
On Error Resume Next
GetHyperLink = Source.HyperLinks(1).Address
End Function

Разобрался, копирую в модуль


Цитата:

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

и начинает работать функция textH

Добавлено:
ZlydenGL
Извини, писал не увидев твоего ответа. У тебя код покороче будет

Привет знатокам!
Научите как осуществить быстрый поиск значений макросом на странице в Excel
Задача примерно такая:
Имеем два листа на одном - первый столбец это искомое значение, а второй столбец результат поиска;
На втором листе тоже 2 столбца на первом - множество значений по которым и будем искать значения с первого листа, а второй столбец - какие-то данные которые в случае удачного поиска будут попадать на первый лист во второй столбец.

Через for .... устал ждать, очень долгая обработка данных, можно сделать как-то, как в базах через locate или select?

Есть 2 варианта.
1. Методом Find (FindNext)
2. Создать 2 массива из стлбцов 1-го и 2-го листов и работать не с ячейками листа, а с элементами массива. Это примерно в 100 раз быстрее.
Какой из методов окажется быстрее, зависит от количества совпадений. Нужно пробовать.

SAS888,
Не работал с массивами, можете показать на примере?
Заранее спасибо

Roka
Для Вашего случая, примерно так:

Код: Sub Main()
Dim i As Long, j As Long, a, b: Application.ScreenUpdating = False
With Sheets(1): a = .Range(.[A1], .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 2)).Value: End With
With Sheets(2): b = .Range(.[A1], .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 2)).Value: End With
For i = 1 To UBound(a, 1)
For j = 1 To UBound(b, 1)
If a(i, 1) = b(j, 1) Then
a(i, 2) = b(j, 2): Exit For
End If
Next
Next
With Sheets(1): .Range(.[A1], .Cells(UBound(a, 1), 2)).Value = a: End With
End Sub

Может кто-то подсказать как сделать в элемент UserForm ComboBox c выпадающим календарем. После указания даты в котором она отображается в окне ComboBox а календарь закрывается

Igor_Paseka
самое простое решение - используй уже готовый элемент "Microsoft Date and Time Picker"

А где этот элемент находится? Спасибо!

Igor_Paseka
В VBE на Toolbox жми правой Additional Controls
тама найдёшь

У меня Офис 2007 ну там я не нашел "Microsoft Date and Time Picker". Может кто-то все-таки напишет код программы. Есть Форма на ней есть выпадающий список ComboBox хочу что-бы при нажатии на ComboBox появлялся календарь в котором выберается дата и она появляетс яв окне ComboBox а календарь сворачивается.
Всем спасиба за помощь.

Igor_Paseka
а ты сам попробуй напиши код, это немного посложнее правда, чем найти Picker. ))
P.S. у меня кстати тоже Офис 2007, хорошая программа )
P.S.S. рисуешь ТекстБокс с Кнопкой - вуаля КомбоБокс, ниже ставишь календарь. В событие формы Инициализ ставишь Visible=false, и на кнопку вешаешь код скрытия/показа календаря Cal.Visible = Not Cal.Visible.
И катайся

Добрый день вашему прекрасному форуму. Помогите чайнику! -
Мне нужно создать своего рода декодировщик. Т.е. при вводе кода в ячейку A1, в ячейке B1 (что напротив) должно происходить декодирование по условиях которые содержатся в столбце №3.
Например:

1) Код: PG Декод: бумага
2) Код: PN Декод: ручка

Я использовал функцию «=ЕСЛИ»:
=ЕСЛИ(F9=C5;O5;ЕСЛИ(F9=C6;O6;ЕСЛИ(F9=C7;O7;ЕСЛИ(F9=C8;O8;ЕСЛИ(F9=C9;O9;ЕСЛИ(F9=C10;O10;ЕСЛИ(F9=C11;O11;ЕСЛИ(F9=C12;O12;"..."))))))))
но она ограничена количеством аргументов (которых у меня немало) и трудоемка.
Помогите ПЛИЗ!

Remalex


Вам подойдет функция ВПР, работает прекрансо

Remalex
вот функция работающая также как и ВПР но более гибкая в плане размещения данных. Также код можно совершенствовать под конкретные нужды )


Код: Function Decod(rngCoded, rngKey, rngDecod)
Dim i As Long, Coded, arrKey(), arrDecod()
arrKey = rngKey.Value
arrDecod = rngDecod.Value
Coded = rngCoded.Value

For i = 1 To UBound(arrKey, 1)
If Coded = arrKey(i, 1) Then Exit For
Next
Decod = arrDecod(i, 1)
End Function

Подскажите, пожалуйста, насколько реально (и какая должна быть схема) сделать следующее:
есть директории на диске, представляющие собой месяца года. В каждой директории есть xls файлы одинаковой структуры. Файл - это дни конкретного месяца. В каждом файле - 20 листов одинаковой структуры, статистические данные. Каждый лист - это несколько показаний каждого (1..20) датчика в определенное время конкретного дня.
Т.е. лист1 = 1 датчик, лист2=2-ой датчик и т.д.

Задача. Делать запрос суммарного характера за определенный период (В каждом листе в каждой строке есть поле даты) по выбранным датчикам.

Предполагаемая реализация: Я тут пытался проконсультироваться и мне сказали, что должны быть 2 подпрограммы.
1) грузящая файлы в общую базу (не все поля из этих листов необходимо грузить в базу)
2) строящая по этой базе запрос, при этом выбирается диапазон дат и необходимые датчики.

Кто что думает по этому поводу? Заранее спасибо.
причем эта система живая, т.е. данные добавляются.

СПАСИБО ВСЕМ!

Mushroomer
мне кажется можно почти без программирования обойтись. Нужно задействовать возможности Access, импортировать данные в базу а дальше очень легко с помощmю запросов SQL

Извините, если на такой вопрос уже отвечали. Просмотрел несколько страниц и не нашел ответа, а читать все 176 как то времени нет... С VBA и Excel-ем знаком не очень хорошо, поэтому возникла проблема. Нужно написать свою функцию, в которую передаются несколько полей (тип Range). Подскажите, можно ли как-нибудь в функции изменять значения в ячейках? (Читал, что нельзя, но все таки может есть решение проблемы?) Надо что-то типа этого, только чтобы работало:

Function qwe (a as range, b as range)
b(1,1) = a(1,1)+3
End Function

Этот пример естественно не отражает всей сложности расчетов, выполняемых функцией. Просто необходимо обеспечить возможность использования функции как стандартной экселевской.

прошу совета
можно ли в VBA делать поиск по ключевым словам без учета их порядка

find(A,B) = find (B,A)
можно ли в операторе поиска управлять порядком ключевых слов\использовать логическое OR\AND\NOT ?
прошу линк или примеров, элементарных...
гугление было, почти поверил что в VBA так нельзя, после нахождения платного аддона к Excel, позволяющему делать !!!FindALL!!!

Korrea
нет. Эксель (возможно к сожалению) устроен так, что НИ ОДНА ФОРМУЛА (а пользовательская фукнция будет использоваться в формулах, верно?) не может изменить содержимое другой ячейки!! НИКАК!
Поэтому, единственный способ (если Вы не хотите использовать формулы, поставленные в те ячейки, которые нужно изменять) решения Вашей задачи - МАКРОСЫ. повесить макросы можно на многие события. например, на событие пересчёта значения ячеек..
или на изменение содержимого листа... и т.п.

antikasper, Вы неправы. на VBA можно сделать ВСЁ.
реализовывайте механизм поиска... пишите свой вариант FindAll. в чём сложности то?..
p.s. к слову, а расширенную фильтрацию пробовали?

Korrea
Excel выдаст ошибку, если это будет пользовательская функция, в противном случае - просто вычислит...
PS Если более подробно опишешь проблему - будет лечге подсказать метод решения...