» Excel VBA

Возможно ли программно или с помощью макроса создать сводную таблицу в Excel-97?

Od_UA

На не более 55 одинаковых групп, несколько медленное решение, но..

Public Sub EqualColorization()
Dim pAll As New Scripting.Dictionary
Dim pGroup As New Scripting.Dictionary
Dim rowLast As Long, colLast As Long
Dim iRow As Long, iCol As Long, vEntry As String
Dim idColor As Long, firstEntry As Excel.Range

rowLast = Cells(1&, 1&).End(xlDown).Row
colLast = Cells(1&, 1&).End(xlToRight).Column
idColor = 57&

For iCol = 1& To colLast
For iRow = 1& To rowLast
vEntry = CStr(Cells(iRow, iCol).Value)
If pAll.Exists(vEntry) Then
If pGroup.Exists(vEntry) Then
Cells(iRow, iCol).Interior.ColorIndex = CLng(pGroup.Item(vEntry))
Else
idColor = idColor - 1&
If idColor < 2& Then idColor = 56&
pGroup.Add vEntry, idColor
Cells(iRow, iCol).Interior.ColorIndex = idColor
Set firstEntry = pAll.Item(vEntry)
firstEntry.Interior.ColorIndex = idColor
End If
Else
pAll.Add vEntry, Cells(iRow, iCol)
End If
Next iRow
Next iCol
End Sub

у меня такой вопрос => как мне сравнивать значение ячеекдвух файлов?

Например
for i=1 to 10000(конец Sheeta нужен если что, может как то еще можно , а то я заведомо большое беру )
for j=1 to 10000 (конец sheeta1 документа Б)
if cells(i:1).value=cells(j:4).value do вот здесь и есть разные файлы
4to to tam
end if
next j
next i

Заранее спасибо!!!
------------------------------------------------------------------------------
Нет я не знаю как мне обратится к другому фаилу(то есть так , как я написал он на одном листе сравнивает а мне надо 2 разных фаила А.xls и Б.xls)
ну и про размер sheeta хотелось бы узнать, а то лишнего много проверяется(вместо 10000 например переменная KonecA u KonecB , которые бы означали кол-во рабочих строк sheeta )

Добавлено:
rowLast = Cells(1&, 1&).End(xlDown).Row
ну вот это как я понимаю ответ на мой вопрос о кол-ве строк
СПАСИБО!!!

AndVGri
Цитата:

Dim pAll As New Scripting.Dictionary

а подскажите, через банальный перебор сверху вниз не быстрее будет?

AsPAndA

Цитата:

rowLast = Cells(1&, 1&).End(xlDown).Row

это вернёт максимальную Строчку только для первого столбца...

и вообще лучше такой код:
'Определить число используемых рядов:
nr = ActiveSheet.UsedRange.Rows.Count
'Прыгаем вверх до последней заполненной ячейки:
lastrow = Cells(nr,col).End(xlUp).Row
'где col - номер нужного столбца

а минимальные/максимально используемые строчки на листе определяются так:
Row1 = ActiveWorkbook.ActiveSheet.UsedRange.Row
Row2 = Row1 + ActiveWorkbook.ActiveSheet.UsedRange.Rows.Count - 1


Цитата:

if cells(i:1).value=cells(j:4).value do вот здесь и есть разные файлы

поясните словами, что вы с чем сравниваете? Равны или НЕ равны? если вы хотите Одни и те же ячейки (одинаковый адрес), только расположенные в разных книгах - то это делается приблизительно так:

set w1 = Workbook("A")
set w2 = Workbook("B")

for i:=row1 to row2
for j=1 to MaxColumn
if w1.cells(i,j).Value = w2.cells(i,j).Value Then
' код
end if
next j
next i

SERGE_BLIZNUK

Цитата:

а подскажите, через банальный перебор сверху вниз не быстрее будет?

Так то будет (n*m/2)*(n*m) просмотров. В идеале, свести всё в одномерный массив и отсортировать, с сохранением индексов ячеек. С другой стороны Dictionary, вроде как, поддерживает хеширование. Короче, проверять надо, что быстрее.


Цитата:

nr = ActiveSheet.UsedRange.Rows.Count

Вы правы, по первой ячейке не стоит определять диапазон данных.
Но если у автора две или более таблиц на листе?
Тогда уж лучше через ActiveSheet.ActiveCell.CurrentRegion.Rows.Count и тоже для столбцов, при условии, что активная в требуемой таблице.

Цитата:

rowLast = Cells(1&, 1&).End(xlDown).Row

это вернёт максимальную Строчку только для первого столбца...

Более того, это вернет не последнюю ячейку, а последнюю заполненную ячейку перед первой пустой или первую заполненную, если А1 пустая. Если надо последнюю ячейку листа всегда используйте UsedRange.

AsPAndA
К другому файл можно обратиться:

Код: Dim wbkOtherBook As Workbook
OtherBook = Workbooks(<адрес твоей книги>).Open

А что возвращается?Последняя ячеика по вертикали или горизонтали? Мне нужна последняя по вертикали

Od_UA
Можно использовать мой макрос "Ранжирование без пробелов" (в шапке). Затем окрасить с помощью ColorIndex.

The okk
set забыл

Добавлено:
AsPAndA

Цитата:

А что возвращается?Последняя ячеика по вертикали или горизонтали? Мне нужна последняя по вертикали

A хелп посмотреть по End и UsedRange напрягает?
Опять же непонятно, что тебе нужно. Последняя заполненная ячейка в столбце или ячейка в последней строке рабочей области листа? Прочувствуй разницу.

AndVGri
Цитата:

Dim pAll As New Scripting.Dictionary
Dim pGroup As New Scripting.Dictionary

1) у меня данный код вообще не отработал - сказал, что не позволяется создавать пользовательские типы данных!
помогла замена на:
Set pAll = CreateObject("Scripting.Dictionary")
Set pGroup = CreateObject("Scripting.Dictionary")
А почему у вас прокатило?

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

Od_UA
Цитата:

В диапазоне А:К найти ячейки с одинаковыми данными

Подскажите, нужно найти строчки, в которых значения во всех столбцах совпадают
или повторы в столбцах надо найти независимо друг от друга (как сделано выше)?

SERGE_BLIZNUK

Цитата:

1) у меня данный код вообще не отработал - сказал, что не позволяется создавать пользовательские типы данных!

В редакторе VBA в меню Tools, пункт Reference в диалоге поставте галочку для Microsoft Scripting Runtime. Я воспользовался ранним связыванием, вы - поздним


Цитата:

2) вопрос в том, что я думал, что нужно решение совсем другой задачи - повторение данных одновременно в нескольких столбцах!

Эта задача, видимо, не совсем корректно поставлена. Действительно, где искать совпадения? В моём варианте ищутся совпадения, как для таблицы, развёрнутой в одномерный массив. Поэтому помечаются ячейки, значения которых равны как в одном столбце, так и в разных. Для разных столбцов не учитывается, находятся ли они в одной строке. А автор вопроса - молчит.

AndVGri

Цитата:

В редакторе VBA в меню Tools, пункт Reference в диалоге поставте галочку для Microsoft Scripting Runtime. Я воспользовался ранним связыванием, вы - поздним

Yes! СПАСИБО!!

Od_UA и всем...
По поводу условного форматирования (выделения дублей в столбце) — решение от Yuk


Цитата:

А автор вопроса - молчит

ну значит можно пока свернуть обсуждение... Пока автор не пояснит, что ему собственно нужно то ;-))

вопросец есть...
Есть в VBA такие строчки:
Set ExpertObj = CreateObject("Expert.Service")
CurrentPath = ExpertObj.ReportFolder
откуда можно узнать, где находится этот "Expert.Service" (в каком файлике EXE/DLL)?

SERGE_BLIZNUK

Цитата:

Set ExpertObj = CreateObject("Expert.Service")
CurrentPath = ExpertObj.ReportFolder

Увы получил ActiveX component can't create object - у меня такого не стоит. Попробуйте в реестре поискать по Expert.Service, COM должна где-то там иметь запись сопоставления Expert.Service некоторму CLID, а по нему можно будет и найти библиотеку, а может и сразу найтёте требуемое

SERGE_BLIZNUK
Если это мелкомягкая вещь, то скорее всего достаточно просто поиском пройтись по system32.

AndVGri
The okk
Спасибо за подсказку. Так и сделаю.
скорее всего вещь не мелкомягкая... это покупная система, работает с БД и сохраняет отчёты в Word, используюя макросы на VBA. скорее всего модуль ActiveX собственной разработки.

На таком-то листе такой-то книги есть именованный диапазон. Можно ли выудить программно сведения о нем (конкретно его границы), не открывая эту книгу? Т.е мне надо использовать ее как источник вот таких вот данных.

Оригинально. - Как вызвать макрос из экселевской формулы. Это ж надо было так извратиться!

Извращаюсь потому, что удобно пользовательский интерфейс так организовывать: говоришь юзеру, что надо выбрать диапазон на листе и назвать его определенным именем. Альтернатива - требовать от него скучного - задания числовых параметров, смысл которых для него неочевиден.

А ссылку не понял, можно подробнее? Мне не из формулы, мне из кода нужно узнать границы именованного ранджа.


---
И еще вопрос собственно о VBA, который я оказывается подзабыл.

Был модуль


Цитата:

Dim m_Series As New Series

Public Function GetSeries() As Series

m_Series.Init2 TargetRange:=Workbooks("Пофамильно3.xls").Sheets("()Образец()").Range("A_D"), _
SourceWorkbookName:="По визитам.xls", _
SourceWorksheetName:="Визит 1", _
SourceNamedRangeName:="A_D_source"



' m_Series.Init FirstRow:=90, _
' LastRow:=103, _
' FirstColumnRef:="R#C56", _
' LastColumnRef:="R#C69"
'
Set GetSeries = m_Series
End Function

Модуль - собственно обертка для моего класса Series, цель которой только вызвать "конструктор" с правильными параметрами. Плохо было в нем то, что одноразовый код инициализации вызывается каждый раз, когда клиентский код дергает GetSeries()

Стал модуль



Цитата:

Dim m_Series As Series

Public Function GetSeries() As Series

If (m_Series Is Nothing) Then
Set m_Series = New Series

m_Series.Init2 ...
End If

Set GetSeries = m_Series
End Function

Все бы хорошо, но таких модулей-оберток несколько (это я имитирую нескольких наследников от класса Series), и я хочу свести к минимуму содержащийся в них код: полиморфизьму ради, чтобы убрать из модулей-оберток повторяющийся код, классовую логику держать все-таки не в модулях, а в классах (ну и в "утилитах класса"). Это поскольку я глубоко развращен интерфейсами и shared мемберами в .NET.


пытаюсь проверять m_Series на Nothing в "утилите класса":


Цитата:

Dim m_Series As Series

Public Function GetSeries() As Series
Utils.Init3 (m_Series)

но так не получается, пишет рантайм еррор 91 object variable not set


Как бы это поизящнее сделать в VBA?

LevT

Сложно сказать, как найти имена в неоткрытой книге. Если же книга не активна, то

Dim pArea As Range
'Получаем ссылку на именованный диапазон
Set pArea = Workbooks("NeedBook").Names("NeedName").RefersToRange

Debug.Print pArea.Row 'Начальная строка диапазона
Debug.Print pArea.Rows.Count 'Число строк в диапазоне
Debug.Print pArea.Column 'Начальный столбец диапазона
Debug.Print pArea.Columns.Count 'Число столбцов диапазона

Есть ищё имена, локальные для рабочего листа, то к ним доступ
Set pArea = Workbooks("NeedBook").Worksheets("NeedSheet").Names("NeedName").RefersToRange

AndVGri

Большое спасибо - но я надеялся, что найдется какая-нибудь функция, которая вытаскивает имена из неоткрытых книг (вернее, даже результат разыменования, и даже его проперти). Есть ведь функции, которые берут из неоткрытых книг данные, та же TRANSPOSE. Почему бы не?..

Подскажите как обойти ошибку деление на ноль. Так как макрос умирает на ошибке Type Mismath у ячейки где есть ошибка ДЕЛ/0.

Код:
Sub rent_check_po_prod()

For i = 1 To 256
If Cells(1, i).Value = "vsgvl" Then vsgvl = i
Next i

For i = 5 To vsgvl - 1
If Cells(16, i).Value > 1.5 Then MsgBox "&ETH;&aring;&iacute;&ograve;&agrave;&aacute;&aring;&euml;&uuml;&iacute;&sup3;&ntilde;&ograve;&uuml; &iuml;&sup3;&auml;&icirc;&ccedil;&eth;&sup3;&euml;&icirc; &acirc;&aring;&euml;&egrave;&ecirc;&agrave;!" & (Cells(4, i))
If Cells(16, i).Value < -0.6 Then MsgBox "&ETH;&aring;&iacute;&ograve;&agrave;&aacute;&aring;&euml;&uuml;&iacute;&sup3;&ntilde;&ograve;&uuml; &iuml;&sup3;&auml;&icirc;&ccedil;&eth;&sup3;&euml;&icirc; &igrave;&agrave;&euml;&agrave;!" & (Cells(4, i))

Next i

End Sub

Sub rent_check_po_prod()

For i = 1 To 256
If Cells(1, i).Value = "vsgvl" Then vsgvl = i
Next i

For i = 5 To vsgvl - 1
If Not Application.WorksheetFunction.IsErr(Cells(16, i).Value) Then
If Cells(16, i).Value > 1.5 Then Msgbox "1"
If Cells(16, i).Value < -0.6 Then MsgBox "2"
End If
Next i

End Sub

hackman

Ну, так что мешает вставить проверку

If IsNumeric(Cells(16, i).Value Then
If Cells(16, i).Value > 1.5 Then Msgbox ...
If Cells(16, i).VAlue < -0.6 Then Msgbox ...
End If

Добавлено:
Olive77

Цитата:

If Not Application.WorksheetFunction.IsErr(Cells(16, i).Value) Then

А если Cells(16, i).Value будет "Я не число"

тогда, конечно, твое решение больше подойдет

Помогите решить такую задачу. Отсканировал таблицу с большим числом строк и при передачи в Excel получилась какая-то ерунда.
Например в ячейке было значение: 1 483,05
5,000
а при передаче в Excel получилось: 1 483,05 5,000
или: 55,08
10,000
получилось: 55,08 10,000
И таких значений великое множество. Может кто поможет с макросом?

aks_sv

Если ты не спец по анализу подобных данных - то тебе поможет только повторное распознавание с тщательной настройкой регионов файнридером

Любым автоматическим макросом сделаешь только хуже. Если решишься на макрос - делай в два этапа, полуавтоматом. Первый макрос красит все интересные места в попугайский цвет и шрифт, второй правит только там, где покрашено, и где при том [не] стоит ручная отметка-подтверждение (вариант такой отметки - возврат к обычному форматированию).

Когда-то занимался подобными вещами в Ворде и Акцесе.

LevT
Я понял, как это получилось:
значения: 55,08
10,000
оказались в одной ячейке потому, что при распозновании в FR в другом столбце напротив 55,08 значение присутствует, а напротив 10,000 нет. В Excel в формате ячейки не стоял перенос по словам, а по ширине значения помещались, поэтому и получилось: 55,08 10,000.
Вопрос в другом: как разделить по ячейкам эти значения?

В экселе - так же как и в ворде, и в акцессовском фильтре импорта - существует команда разбиения текста по столбцам. Кажется, тебе туда.

aks_sv
вот макрос, который находит такие ячейки, разделяет на два числа и записывает в ячейки справа от обработанной. Доработав пример Вы получите то, что Вам нужно:

Код:
Sub Asplit()
Set w1 = ActiveWorkbook.ActiveSheet
MyCol = 2 ' обрабатываем столбец 2
Row1 = w1.UsedRange.Row
Row2 = Row1 + w1.UsedRange.Rows.Count - 1

For i = Row1 To Row2
MyType = TypeName(w1.Cells(i, 2).Value)
If (MyType = "String") Then
s = w1.Cells(i, MyCol).Value
posSpace = InStr(Trim(s), " ")
If posSpace > 0 Then
s1 = Trim(Mid(s, 1, posSpace))
s2 = Trim(Mid(s, posSpace + 1))
d1 = Val(s1)
d2 = Val(s2)
If (d1 <> 0) And (d2 <> 0) Then
' вот здесь обработка найденных значений!
w1.Cells(i, MyCol+1).Value = d1
w1.Cells(i, MyCol+2).Value = d2
End If
End If
End If
Next i
End Sub

Экспериментировал с нестандартным использованием UDF-ов. В них можно напихать все, что угодно - можно вызвать формулой MsgBox, менять комменты ячеек... в общем, все... кроме действий, вызывающих рекалькуляцию. Т.е. все попытки запихать что-нибудь типа Cell.Value = 100 или Cell.FormulaR1C1 = "=A5 + A1" между Function и End Function успехом не увенчаются. Причем, функция вылетит на этих строках без сообщения об ошибке.