» Excel VBA

Anton T
Если задача формулируется так
Цитата:

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

то код такой

Код: Dim strAr() As String
Dim i As Integer, j As Integer
Dim ws As Worksheet

Private Sub TextBox1_Change()
FillLB (TextBox1.Text)
End Sub

Sub FillArray()
For Each ws In ActiveWorkbook.Worksheets
If Len(ws.Name) = 1 Then
For Each r In ws.UsedRange.Rows
ReDim Preserve strAr(i)
strAr(i) = ws.Cells(r.Row, ws.UsedRange.Column).Value
i = i + 1
Next r
End If
Next ws
End Sub

Private Sub UserForm_Initialize()
i = 0
ListBox1.Clear
FillArray
FillLB (TextBox1.Text)
End Sub

Sub FillLB(strMask As String)
ListBox1.Clear
For j = 0 To i - 1
If StrComp(Left(strAr(j), Len(TextBox1.Text)), strMask, 1) = 0 Then
ListBox1.AddItem strAr(j)
End If
Next j
End Sub

Спасибо. Голова кругом идет...

Troitsky

Цитата:

ReDim Preserve strAr(i)

Я в таких случаях, когда надо делать ReDim Preserve всегда вместо array использую Class и Collection. Намного быстрее и удобнее. ReDim Preserve очень дорогостоящая операция. А с классом больше возможностей, да и основной код проще. Всю спесифику забираем в класс. Ещё одно достоинство в том, что можно не заботиться про duplicate key. В Сollection его не добавишь

[more=сделал ListView, а ошибку дает Type mismatch '13']
Код:
Option Explicit
Dim strAr() As String
Dim i As Integer, j As Integer

Private Sub okBut_Click()
Unload Me
End Sub
Sub txtFiltBox_change()
FillLB (txtFiltBox.Text)
End Sub
Private Sub txtFiltBox_Enter()
With txtFiltBox
.BackColor = RGB(205, 236, 253)
.Font.Bold = True
End With
End Sub

Private Sub txtFiltBox_Exit(ByVal Cancel As MSForms.ReturnBoolean)
With txtFiltBox
.BackColor = RGB(255, 255, 255)
.Font.Bold = False
End With
End Sub
Sub FillArray()
Dim RowCounter As Long
Dim ls As Worksheet

With ListView1 'è â ListView
.ColumnHeaders.Add , , "Ôàìèëèÿ", 75 'Ôàìèëèÿ
.ColumnHeaders.Add , , "Èìÿ", 60 'Èìÿ
.ColumnHeaders.Add , , "Îòå÷åñòâî", 70 'Îòå÷åñòâî
.ColumnHeaders.Add , , "Ãîðîä", 45 'Ãîðîä
.ColumnHeaders.Add , , "Àäðåñ", 115 'Àäðåñ
.ColumnHeaders.Add , , "äîì", 30 'Äîì
.ColumnHeaders.Add , , "êâ.", 30 'Êâàðòèðà
.ColumnHeaders.Add , , "Êíèãà 1", 40 'Êèíãà 1
.ColumnHeaders.Add , , "Êíèãà 2", 40 'Êíèãà 2
.ColumnHeaders.Add , , "Ñòðàíèöà", 50 'Ñòðàíèöà
.ColumnHeaders.Add , , "Ðååñòð ¹", 50 'Ðååñòðîâûé íîìåð
.Gridlines = True 'ðèñóåì ñåòêó (èáî óäîáíî!)
.View = lvwReport 'âûâîäèòü îòñ÷åòà


For Each ls In ActiveWorkbook.Worksheets 'â êàæäîì ëèñòå
If Len(ls.Name) = 1 Then
For RowCounter = 1 To ls.UsedRange.Rows.Count 'ïðîõîäèì ïî âñåì ñòðîêàì
'ReDim Preserve strAr(i)
With .ListItems
.Add = ls.Cells(RowCounter, 1) 'äîáàâëÿåì ýëåìåíò (Ôàìèëèþ)
.Item(.Count).SubItems(1) = ls.Cells(RowCounter, 2) 'è åãî ïîäýëåìåíòû (Èìÿ)
.Item(.Count).SubItems(2) = ls.Cells(RowCounter, 3) 'Îòå÷åñòâî
.Item(.Count).SubItems(3) = ls.Cells(RowCounter, 4) 'Ãîðîä
.Item(.Count).SubItems(4) = ls.Cells(RowCounter, 5) 'Àäðåñ
.Item(.Count).SubItems(5) = ls.Cells(RowCounter, 6) 'Äîì
.Item(.Count).SubItems(6) = ls.Cells(RowCounter, 7) 'Êâàðòèðà
.Item(.Count).SubItems(7) = ls.Cells(RowCounter, 8) 'Êíèãà 1
.Item(.Count).SubItems(8) = ls.Cells(RowCounter, 9) 'Êíèãà 2
.Item(.Count).SubItems(9) = ls.Cells(RowCounter, 10) 'Ñòðàíèöà
.Item(.Count).SubItems(10) = ls.Cells(RowCounter, 11) 'Ðååñòð ¹
End With
'i = i + 1
Next
End If
Next
End With
End Sub
Private Sub UserForm_Initialize()
i = 0
ListView1.ListItems.Clear
FillArray
FillLB (txtFiltBox.Text)
End Sub
Sub FillLB(strMask As String)
ListView1.ListItems.Clear
For j = 0 To i - 1
If StrComp(Left(strAr(j), Len(txtFiltBox.Text)), strMask, 1) = 0 Then
ListView1.ListItems.Add strAr(j)
End If
Next j
End Sub

Возникла следующая надобность. Нужна реализация функции, которая производит выборку из N чисел, выбирает из них число с максимальным отклонением от заданного. Пример: Имеется 3 числа 4003, 3992, 3998. Нужно среди них выбрать число с максимальным отклонением от заданного - 4000. Этим числом будет число - 3992, как число с наибольшим отклонением - -8. Функции МАКС и МИН не подходят, так как число с максимальным отклонением может быть как больше заданного ( МИН не подходит), так и меньше заданного ( МАКС не подходит). Подскажите - какую функцию использовать для реализации данной задачи? Очень надо...

sanek1106
Sub GoToMax()
' Активизирует ячейку с наибольшим значением
Dim WorkRange As Range
Dim MaxVal As Double

' Выход, если диапазон не выбран
If TypeName(Selection) <> "Range" Then Exit Sub

' Если выбрана одна ячейка, поиск по всему листу;
' в противном случае – поиск в выделенном диапазоне
If Selection.Count = 1 Then
Set WorkRange = Cells
Else
Set WorkRange = Selection
End If

' Определение максимального значения
MaxVal = Application.Max(WorkRange)

' Поиск и выделение ячейки с максимальным значением
On Error Resume Next
WorkRange.Find(What:=MaxVal, _
After:=WorkRange.Range("A1"), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False _
).Select
If Err <> 0 Then MsgBox "Максимальное значение не найдено: " _
& MaxVal
End Sub

Добавлено:
MaxVal = Application.Max(WorkRange) вместо заменить на MaxVal = Application.Min(WorkRange) - это минимальное значение

sanek1106
Лучше в тему по Excel.

Yuk

Цитата:

Для определения последней непустой ячейки в столбце предлагаю такой код:
Код:Cells(ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count, 1).End(xlUp)

Может, можно обойтись без вычислений?:

Код: Cells(Rows.Count,1).End(xlUp)

The okk
Погонял в цикле. Да, так быстрее получается и код проще. Интересно было бы потестировать в 2007-м.

Yuk
По идее, результат в 2007-м должен быть таким же. Ведь End - это не метод, а свойство объекта. Обращение к свойству по определению должно отрабатывать быстрее...

А ты свой код как тестировал? Именно в таком виде?:

Цитата:

Cells(ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count, 1).End(xlUp)

Может, имеет смысл попробовать:

Код: With ActiveSheet.UsedRange
Cells(.Row+Rows.Count,1).End(xlUp)
End With

Всем привет!

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

Задача - выдернуть из файла Excel, Word статистику: создания, изменения файла, Total editing time , количество символов , и сохранить эту инфу в другом файле Excel.

Вся инфа тут: File > Properties > Statistics.

Есть ли какие-нить функции в VBA, чтобы это оперативно и безболезнено сделать ?

RMKusto

Цитата:

Есть ли какие-нить функции в VBA, чтобы это оперативно и безболезнено сделать ?

Получить данные книги можно с помощью кода:

Код: WorkBook(твоя_книга).BuiltInDocumentProperties

RMKusto
если бы вы почитали форум - то нашли бы ссылки (тут было обсуждение)... ;-)))
ищите BuiltinDocumentProperties А вот пример из хелпа к VBA (к Word): [more]

Код: Sub ListProperties()
Dim rngDoc As Range
Dim proDoc As DocumentProperty

Set rngDoc = ActiveDocument.Content

rngDoc.Collapse Direction:=wdCollapseEnd

For Each proDoc In ActiveDocument.BuiltInDocumentProperties
With rngDoc
.InsertParagraphAfter
.InsertAfter proDoc.Name & "= "
On Error Resume Next
.InsertAfter proDoc.Value
End With
Next
End Sub

В VBA ноль.. Помогите плз релиазовать следующую задачку

Допустим на листе1 есть 10 столбцов 10 строк. (количество строк может менятся)

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

Очень желательно чтобы ячейки копировались без изменения размеров.
В исходном же листе1 всю строку надо выделить определенным цветом.

Зарание БОЛЬШОЕ СПАСИБО

В панели Форма есть список


Как привязать скрол мышки к этому списку.Т.е.
Как сделать так чтобы при помощи скрола можно было двигать двигать
данные в списке а не страницу целиком.

Наконец-то сделал [more=массив]
Код: Dim MyArray(10)

Sub fil()
Dim ws As Worksheet
Dim i As Single
ListBox1.ColumnCount = 11
For i = 0 To 10
MyArray(i) = i
Next i
For Each ws In ActiveWorkbook.Worksheets 'на каждом листе
For Each ww In ws.UsedRange.Rows 'по всем строкам
MyArray(0) = ws.Cells(ww.Row, 1).Value 'Фамилия
MyArray(1) = ws.Cells(ww.Row, 2).Value 'Имя
MyArray(2) = ws.Cells(ww.Row, 3).Value 'Отечество
MyArray(3) = ws.Cells(ww.Row, 4).Value 'Город
MyArray(4) = ws.Cells(ww.Row, 5).Value 'Адрес
MyArray(5) = ws.Cells(ww.Row, 6).Value 'Дом
MyArray(6) = ws.Cells(ww.Row, 7).Value 'Квартира
MyArray(7) = ws.Cells(ww.Row, 8).Value 'Книга 1
MyArray(8) = ws.Cells(ww.Row, 9).Value 'Книга 2
MyArray(9) = ws.Cells(ww.Row, 10).Value 'Страница
MyArray(10) = ws.Cells(ww.Row, 11).Value 'Реестровый номер
Next ww
Next ws
ListBox1.Column = MyArray
End Sub
Private Sub UserForm_Initialize()
'ListBox1.Clear
fil
End Sub

Anton T

Цитата:

Я не понял, почему отображается одна строка ???

Все правильно. при каждом проходе массив переписывается и в конце остается последняя строка последнего листа.

Yuk
Почему так? А жаль.

Anton T

Цитата:

Наконец-то сделал массив Я не понял, почему отображается одна строка ???

Цитата:

Почему так? А жаль.

Да потому что у тебя массив одномерный. Почитай про двумерные массивы.

Сейчас будете смеяться:
я в Оbject Browser'e не нашел некоторые свойства объектов, которые у них 100% должны быть. Долго ломал голову, что за ерунда. Оказывается, всего лишь не включил Show Hidden Members. Надо это в шапку добавить:
По умолчанию в Object Browser не отображаются скрытые методы и свойства.
Если кликнуть правой кнопкой мыши в правом окошке Object Browser’а (там, где нарисованы члены классов), то выскочит контекстное меню с командой Show Hidden Members. Если щелкнуть на этой команде, то отныне Object Browser будет показывать все hidden-свойства и методы (а также и классы) любой библиотеки, и Вы можете использовать это для более детального исследования библиотек объектов. Взял оттуда

Есть функция на VBA.
Как сделать, чтобы ее можно было вызывать из ячейки на листе?

Aladdinych
Объяви ее, как Public:
Код:
Public Function MyFunc()
'тут код твоей функции
End Function

The Okk, спасибо.

Толкько как запустить эту штуку?

Извините но VBA на прошлой неделе начал изучать , ещё не совсем понимаю походу...
Ввожу код в VBA editor. Вместо "Книга1" подставляю название книги "Testbook".

Получается:


Код:
Sub GetDocProp

Dim objProperty As Object

Set objProperty = WorkBook("Testbook").BuiltInDocumentProperties(30)

End Sub


Выдаёт ошибку: Compile Error: Sub or function not defined
Насколько я понимаю это он ругается функцию Workbook

Пробовал Dim workbook as string, object, variant и т.д. - не катит, каждый раз другая ошибка...

Подскажите что я делаю не так?


SERGE_BLIZNUK,

Sub ListProp()
rw = 1
Worksheets(1).Activate
For Each p In ActiveWorkbook.BuiltinDocumentProperties
Cells(rw, 1).Value = p.Name
On Error Resume Next
Cells(rw, 2).Value = p.Value
rw = rw + 1
Next
End Sub

Тоже выдаёт ошибку: Compile Error, Variable not defined, ругается на rw

RMKusto

Код: Sub ListProp()
Dim rw As Long, p As Object
rw = 1
Worksheets.Add
For Each p In ActiveWorkbook.BuiltinDocumentProperties
Cells(rw, 1).Value = p.Name
On Error Resume Next
Cells(rw, 2).Value = p.Value
rw = rw + 1
Next
End Sub

The okk

От души благодарю

Всё рабоает

SERGE_BLIZNUK

И вас от души благодарю, для Worda код тоже пашет

Пишу макрос для Excel 2003, в нем есть такая строчка:

Код: Range("A" & k).Formula = "=ДАТА(ГОД(Y" & k & "), МЕСЯЦ(Y" & k & "), ДЕНЬ(A8))"

griin

Цитата:

Range("A" & k).Formula = "=ДАТА(ГОД(Y" & k & "), МЕСЯЦ(Y" & k & "), ДЕНЬ(A8))"

или пиши наименования функций по-английски (список соответствия в шапке) или .FormulaLocal

М-да! Прочти MacroUnit Excel QuickSearch –специальная реализация функции поиска (MS Excel 2000/XP/2003)

Добавлено:
Пробная версия 14 дней

griin

Код: Range("A" & k)

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

Артикул    Наименование    Цена 1    Цена 2
47212    Процессор AMD     903.88
47213    Процессор AMD     1054.92    1025.42
47184    Процессор AMD     1348.74    1309.8
55336    Процессор AMD     1253.16

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

Pantera3587
Это и без кода можно сделать - выделяешь столбцы, жмешь Правка - Заменить.