» Excel VBA (часть 3)

Помогите пожалуйста, нужно осуществить такую вещь:
- Есть таблица (Т1), 65k+ строк (список книг для продажи), у каждой стоит поле "Издательство"
- Вторая таблица (Т2) - список издательств (первая колонна) и скидки, которые положены по ним (вторая колонна)
- нужно каждой книге в Т1 расставить скидку в сооответствии с издательством, причем, как можно быстрее.

Понимаю, что тупым перебором строк из Т1 и сравнением с Т2, скрипт будет выполняться пару недель на Атоме . С помощью запроса бы — к выборке по издательству применить значение… Что-то вроде:

Код:
UPDATE T1 SET T1.Sale = T2.CurrentPublisherSale WHERE T1.Publisher = T2.CurrentPublisher

DmAnatolich, см. стандартную функцию Excel ВПР(), её не раз обсасывали в Excel FAQ. И не надо из-за такой ерунды VBA городить.

Добавлено:
indapublic
Цитата:

Написал скрипт, который в цикле удаляет строки. Проблема в том, что строки, в которых есть объединенные ячейки не удаляются. можно ли что-то сделать в этой ситуации?

Код: Selection.UnMerge
Selection.Delete Shift:=xlUp

Цитата:

Не устраивает?

Устраивает, спасибо.

DmAnatolich
у меня работает вот такой [more=код]

Код: Private Sub sql()
Dim cn As ADODB.Connection, rs As ADODB.Recordset
Set cn = New ADODB.Connection
cn.Open "Provider=SQLOLEDB;Data Source=PC-SERVER\SQLBLBLBLBLBL;" & _
"Initial Catalog=имя_базы_данных;User ID=имя_пользователя;Password=пароль"
Set rs = New ADODB.Recordset
With rs
.ActiveConnection = cn
.Open "UPDATE T1 SET T1.Sale = T2.CurrentPublisherSale WHERE T1.Publisher = T2.CurrentPublisher"
'ActiveSheet.Range("A2").CopyFromRecordset rs
.Close
End With
cn.Close
Set rs = Nothing
Set cn = Nothing
End Sub

Подскажите пожалуйста такой момент. При записи формул для ячейки в формате R1C1 (ActiveCell.FormulaR1C1 =) можно ли в такой конструкции указать, что ее нужно применить, скажем, к последней заполненной ячейке первого столбца или адрес ячейки должен быть указан явно?

В общем, лучше такой объем перенести в нормальную БД — сподручнее будет . Всем спасибо, и то (ВПР()), и другое (ADO) работает, хоть и не без галюнов.

Буду очень признателен за подсказку.
Как сделать такую конструкцию?
1. Сделать выборку всех совпадающих ячеек A+B+С
2. Сравнить и вычислить с помощью логики. Для конкретного примера (файл прикреплен) вижу такую логику
Если A3+B3+C3=A7+B7+C7 и D7=”живет” и E7>E3 то СЧЕТ (или истина)

То есть, по логике вычислить: (1)что человек вернулся, (2) сколько человек вернулось.

Буду признателен за формулу или макрос (office 2007/2010). файл-пример прикладываю (файл-пример в 2-х форматах office 2003/2007).

http://ifolder.ru/27577339

запускаю из Excel скрипт VBS с параметром
Arg = Cells(i, 3).Value
Shell ("C:\Program Files\Radmin Viewer 3\VBS.vbs /" + Arg)

Ошибка
Excel VBS Run-time Error 5 Invalid procedure call or argument

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

Такой вопрос. у меня есть диапазон ячеек с разными фразами . как мне написать формулу, что если у меня в этом диапазоне есть фраза (например хорошо) то чтобы мне выдало общее количество этих (хорошо). формула может типа счетесли? Спасибо!

denisAzef

Код: For each ячейка in range("диапазон")
if instr(1, ячейка, "хорошо")<>0 then n=n+1
Next
msgbox n

DmAnatolich
Понимаю - поздно, но вдруг пригодится...
Если нужно быстрее - то думаю нужно на словаре делать.
1. диапазоны в массивы.
2. издательства со скидками одним перебором в словарь
3. создаём чистый массив под результат (или как вариант исходный массив делаем пошире)
3. книги проверяем по словарю, копируем скидку к книге в массив
4. выгружаем массив результатов

Итого - два прохода по двум массивам и выгрузка (поиск в словаре моментальный).
Думаю секунд 5-10 или быстрее получится, не проверял.

В каждом столбце и каждой строке матрицы P(n, n) содержится строго по одному нулевому элементу. Перестановкой строк добиться расположения всех нулей по главной диагонали матрицы.

Здравствуйте, буду признателен за помощь, уже голву сломал.

Суть задачи:

Вобщем есть xls файл, в нем присутствует столбец с ячейками примерно такого содержания и формата


Код: слово слово слово слово слово слово слово

savvato
Цикл по ячейкам - просто, даже останавливаться на этом не стоит.
Есть объект CellFormat - можно прочитать / изменить формат ячейки. После проверки записать нужный текст в нужную ячейку.

BASTETA
Перестановкой какой?
Циклически передвинуть все значения в строке, так чтобы 0 оказался на главной диагонали?
Или переставить 0 с числом, стоящим на главной диагонали?
savvato
насколько понял. Пример для активной ячейки.

Код:
Public Sub SplitBoldNormal()
Dim sBold As String, sNormal As String
Dim pChar As Characters, i As Long
Dim pChars As Characters
Set pChars = ActiveCell.Characters
sBold = "": sNormal = ""
For i = 1 To pChars.Count
Set pChar = ActiveCell.Characters(i, 1)
If pChar.Font.Bold Then
sBold = sBold & pChar.Text
Else
sNormal = sNormal & pChar.Text
End If
Next i
ActiveCell.Offset(0, 1).Value = sBold
ActiveCell.Offset(0, 2).Value = sNormal
End Sub

помогите со следующем. в одном из модулей объявлены X публичных констант, формат следующий
TC001
TC002
...
TCXXX

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


Код: Sub dd()
Dim i
ReDim TestCases(TEST_CASES_COUNT, 4)

For i = 1 To TEST_CASES_COUNT
If (TypeName("TC" & Format(i, "000")) <> "Empty") Then
TestCases(i, 1) = ' &#247;&#242;&#238; &#231;&#228;&#229;&#241;&#252; &#237;&#224;&#239;&#232;&#241;&#224;&#242;&#252; &#247;&#242;&#238;&#225;&#251; &#239;&#238;&#235;&#243;&#247;&#232;&#242;&#252; &#231;&#237;&#224;&#247;&#229;&#237;&#232;&#229; &#234;&#238;&#237;&#241;&#242;&#224;&#237;&#242;&#251;.
End If
Next

End Sub

KF121
Боюсь, что в вашем коде TypeName() всегда будет возвращать String, не говоря уж о получении результата ...

Мне пришла в голову мысль для вычисления констант использовать динамическое создание функций:

Цитата:

Sub CreateTestVarProc(VarName As String)
On Error Resume Next
Dim S As String
Dim m As CodeModule
Set m = Workbooks(1).VBProject.VBComponents("ThisWorkbook").CodeModule
S = "public Function TestVar() as String" & Chr(13) & _
"TestVar = " & VarName & Chr(13) & _
"End Function"
'удалить предыдущую функцию
m.DeleteLines (1)
m.DeleteLines (1)
m.DeleteLines (1)
'добавить новую функцию
m.AddFromString (S)

End Sub

Function TestVar1(VarName As String)
'создать функцию проверки имени
CreateTestVarProc (VarName)
'выполнить функцию и вернуть результат
TestVar1 = ThisWorkbook.TestVar()
End Function

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

Поэкспериментируй в этом направлении, может, что-то получится.

AndVGri cпасибо, помогло

Доброго времени суток, нужна помощь продвинутых светлых голов, тк в моей светлости не хватает к сожалению. Ниже приведён мой очень длинный код, опишу в двух словах в чём идея: я задаю 17 одномерных массивов (длинны kolvo, в идеале длинна должна быть 5000), которые по мере выполнения программы заполняются разными числами, всячески преобразуются и затем выводятся на лист. Но, в данном виде у меня выходит ошибка Overflow, вот и хочется узнать, можно ли как-то выйти из ситуации?
P.S. Есть аналог этой программы без массивов- все преобразования ведутся с ячейками на листе, но в таком виде она очень долго работает (порядка 4-5 часов), вот я решил что если производить операции с массивами то так будет быстрее и написал то что получилось.

[more=Очень длинный код.]
Код:

Public Sub stringi()
Range("t1") = time()

'For j = 2 To 7002
'For i = 4 To 30
'ActiveSheet.Cells(j, i).Clear
'Next
'Next
kolvo = 20
Dim h() As Boolean
ReDim h(1 To kolvo)
Dim E() As Boolean
ReDim E(1 To kolvo)
Dim D() As Boolean
ReDim D(1 To kolvo)
Dim Ass() As Boolean
ReDim Ass(1 To kolvo - 1)
Dim Eks() As Boolean
ReDim Eks(1 To kolvo - 1)
Dim w() As Boolean
ReDim w(1 To kolvo)
Dim x() As Boolean
ReDim x(1 To kolvo)
Dim corr1() As Boolean
ReDim corr1(1 To kolvo - 1)
'Dim corr2() As Boolean
'ReDim corr2(1 To kolvo - 1)
'Dim corr3() As Boolean
'ReDim corr3(1 To kolvo - 1)
'Dim corr4() As Boolean
'ReDim corr4(1 To kolvo - 1)
'Dim corr5() As Boolean
'ReDim corr5(1 To kolvo - 1)
'Dim corr6() As Boolean
'ReDim corr6(1 To kolvo - 1)
'Dim corr7() As Boolean
'ReDim corr7(1 To kolvo - 1)
'Dim corr8() As Boolean
'ReDim corr8(1 To kolvo - 1)
'Dim corr9() As Boolean
'ReDim corr9(1 To kolvo - 1)
'Dim corr10() As Boolean
'ReDim corr10(1 To kolvo - 1)


j = 0

' s4itaem h

For j = 1 To kolvo
h(j) = Cells(j + 2, 3).Value
Next j

' s4itaem E

For j = 1 To kolvo
k = 0
For i = 1 To j
k = k + h(i)
Next i
E(j) = k / j
Next j

' s4itaem D

For j = 1 To kolvo
c = 0
For i = 1 To j
c = c + (h(i) - E(j)) ^ 2
Next i
D(j) = c / j
Next j

' s4itaem Ass

For j = 2 To kolvo
c = 0
For i = 1 To j
c = c + (h(i) - E(j)) ^ 3
Next i
Ass(j) = c / (j * D(j) ^ (3 / 2))
Next j

' s4itaem Eks

For j = 2 To kolvo
c = 0
For i = 1 To j
c = c + (h(i) - E(j)) ^ 4
Next i
Eks(j) = c / (j * D(j) ^ (2)) - 3
Next j

's4itaem Corr

c = 0
i = 0
j = 0
k = 0
t = 1
For j = 1 To kolvo
k = 0
For i = 1 To j
k = k + h(t + i)
Next i
w(j) = k / j
Next j
i = 0
j = 0
For j = 1 To kolvo
c = 0
For i = 1 To j
c = c + (h(t + i) - w(j)) ^ 2
Next i
x(j) = c / j
Next j

For j = 2 To kolvo - t
c = 0
For i = 1 To j
c = c + (h(i) - E(j)) * (h(i + t) - w(j))
Next i

corr1(j) = c / (j * Sqr(D(j)) * x(j))

Next j

t = 2
For j = 1 To kolvo
k = 0
For i = 1 To j
k = k + h(t + i)
Next i
w(j) = k / j
Next j
i = 0
j = 0
For j = 1 To kolvo
c = 0
For i = 1 To j
c = c + (h(t + i) - w(j)) ^ 2
Next i
x(j) = c / j
Next j

For j = 2 To kolvo - t
c = 0
For i = 1 To j
c = c + (h(i) - E(j)) * (h(i + t) - w(j))
Next i

corr2(j) = c / (j * Sqr(D(j)) * x(j))

Next j

t = 3
For j = 1 To kolvo
k = 0
For i = 1 To j
k = k + h(t + i)
Next i
w(j) = k / j
Next j
i = 0
j = 0
For j = 1 To kolvo
c = 0
For i = 1 To j
c = c + (h(t + i) - w(j)) ^ 2
Next i
x(j) = c / j
Next j

For j = 2 To kolvo - t
c = 0
For i = 1 To j
c = c + (h(i) - E(j)) * (h(i + t) - w(j))
Next i

corr3(j) = c / (j * Sqr(D(j)) * x(j))

Next j

t = 4
For j = 1 To kolvo
k = 0
For i = 1 To j
k = k + h(t + i)
Next i
w(j) = k / j
Next j
i = 0
j = 0
For j = 1 To kolvo
c = 0
For i = 1 To j
c = c + (h(t + i) - w(j)) ^ 2
Next i
x(j) = c / j
Next j

For j = 2 To kolvo - t
c = 0
For i = 1 To j
c = c + (h(i) - E(j)) * (h(i + t) - w(j))
Next i

corr4(j) = c / (j * Sqr(D(j)) * x(j))

Next j

t = 5
For j = 1 To kolvo
k = 0
For i = 1 To j
k = k + h(t + i)
Next i
w(j) = k / j
Next j
i = 0
j = 0
For j = 1 To kolvo
c = 0
For i = 1 To j
c = c + (h(t + i) - w(j)) ^ 2
Next i
x(j) = c / j
Next j

For j = 2 To kolvo - t
c = 0
For i = 1 To j
c = c + (h(i) - E(j)) * (h(i + t) - w(j))
Next i

corr5(j) = c / (j * Sqr(D(j)) * x(j))

Next j

t = 6
For j = 1 To kolvo
k = 0
For i = 1 To j
k = k + h(t + i)
Next i
w(j) = k / j
Next j
i = 0
j = 0
For j = 1 To kolvo
c = 0
For i = 1 To j
c = c + (h(t + i) - w(j)) ^ 2
Next i
x(j) = c / j
Next j

For j = 2 To kolvo - t
c = 0
For i = 1 To j
c = c + (h(i) - E(j)) * (h(i + t) - w(j))
Next i

corr6(j) = c / (j * Sqr(D(j)) * x(j))

Next j

t = 7
For j = 1 To kolvo
k = 0
For i = 1 To j
k = k + h(t + i)
Next i
w(j) = k / j
Next j
i = 0
j = 0
For j = 1 To kolvo
c = 0
For i = 1 To j
c = c + (h(t + i) - w(j)) ^ 2
Next i
x(j) = c / j
Next j

For j = 2 To kolvo - t
c = 0
For i = 1 To j
c = c + (h(i) - E(j)) * (h(i + t) - w(j))
Next i

corr7(j) = c / (j * Sqr(D(j)) * x(j))

Next j

t = 8
For j = 1 To kolvo
k = 0
For i = 1 To j
k = k + h(t + i)
Next i
w(j) = k / j
Next j
i = 0
j = 0
For j = 1 To kolvo
c = 0
For i = 1 To j
c = c + (h(t + i) - w(j)) ^ 2
Next i
x(j) = c / j
Next j

For j = 2 To kolvo - t
c = 0
For i = 1 To j
c = c + (h(i) - E(j)) * (h(i + t) - w(j))
Next i

corr8(j) = c / (j * Sqr(D(j)) * x(j))

Next j

t = 9
For j = 1 To kolvo
k = 0
For i = 1 To j
k = k + h(t + i)
Next i
w(j) = k / j
Next j
i = 0
j = 0
For j = 1 To kolvo
c = 0
For i = 1 To j
c = c + (h(t + i) - w(j)) ^ 2
Next i
x(j) = c / j
Next j

For j = 2 To kolvo - t
c = 0
For i = 1 To j
c = c + (h(i) - E(j)) * (h(i + t) - w(j))
Next i

corr9(j) = c / (j * Sqr(D(j)) * x(j))

Next j

t = 10
For j = 1 To kolvo
k = 0
For i = 1 To j
k = k + h(t + i)
Next i
w(j) = k / j
Next j
i = 0
j = 0
For j = 1 To kolvo
c = 0
For i = 1 To j
c = c + (h(t + i) - w(j)) ^ 2
Next i
x(j) = c / j
Next j

For j = 2 To kolvo - t
c = 0
For i = 1 To j
c = c + (h(i) - E(j)) * (h(i + t) - w(j))
Next i

corr10(j) = c / (j * Sqr(D(j)) * x(j))

Next j

' &#226;&#251;&#226;&#238;&#228;
i = 20
For j = 1 To kolvo
Cells(j + 1, i + 1).Value = E(j)
Next j
For j = 1 To kolvo
Cells(j + 1, i + 2).Value = D(j)
Next j
For j = 1 To kolvo - 1
Cells(j + 1, i + 3).Value = Ass(j)
Next j
For j = 1 To kolvo - 1
Cells(j + 1, i + 4).Value = Eks(j)
Next j
For j = 1 To kolvo - 1
Cells(j + 1, i + 5).Value = corr1(j)
Next j
For j = 1 To kolvo - 1
Cells(j + 1, i + 6).Value = corr2(j)
Next j
For j = 1 To kolvo - 1
Cells(j + 1, i + 7).Value = corr3(j)
Next j
For j = 1 To kolvo - 1
Cells(j + 1, i + 8).Value = corr4(j)
Next j
For j = 1 To kolvo - 1
Cells(j + 1, i + 9).Value = corr5(j)
Next j
For j = 1 To kolvo - 1
Cells(j + 1, i + 10).Value = corr6(j)
Next j
For j = 1 To kolvo - 1
Cells(j + 1, i + 11).Value = corr7(j)
Next j
For j = 1 To kolvo - 1
Cells(j + 1, i + 12).Value = corr8(j)
Next j
For j = 1 To kolvo - 1
Cells(j + 1, i + 13).Value = corr9(j)
Next j
For j = 1 To kolvo - 1
Cells(j + 1, i + 14).Value = corr10(j)
Next j

Range("t2") = time()
End Sub

помогите написать макрос для excel

есть ячейка А1 которая будет изменятся каждые 24часа, и надо что бы данные етой ячейки(не формула) дублировалась в столбец Б

вначале ячека А1 просто скопировалась в ячейку B1 далее при повторном выполнение макроса ячейка А1 копировалась в ячейку B2, потом я ячейку B3..

(надо мониторить изменения ячейка А1)

Привет всем
Помогите как можно открыть *xla vba код говорит project is unviewable
Попробовал через Open Office открыть без результатно..

mrUlugbek

Q: При открытии XLA-файла я получаю сообщение "Project is unviewable". Как посмотреть проект ?
A: Надо снять флаг "Add-in". Подробнее - в описании формата MS Excel. Начиная с версии 1.2, это позволяет сделать Advanced VBA Password Recovery.

Ну и еще если вам известен пароль от проекта тогда вам сюда http://www.sql.ru/forum/actualthread.aspx?bid=22&tid=346886&hl=vbcomponents#3232797

Jizo
VBA конечно умный и приводит Ваши вычисления к Integer (так интерпретирует Boolean - типом, которым объявлены все массивы), но лучше использовать Double для объявления массивов, раз выполняются численные вычисления.

Цитата:

t = 3
For j = 1 To kolvo
k = 0
For i = 1 To j
k = k + h(t + i)
Next i
w(j) = k / j
Next j

этот код приведёт к ошибке Out Of Range так как Redim h(1 to kolvo), а t + i может быть равно kolvo + 3. Причёсывайте.
5106046
А что не получается?

JekG
Получилось через Password recovery unlock add-in
Спасибо огромное за помощь...

Всем привет! Помогите доработать макрос, суть которого заключается в том, что в режиме реального времени будет поступать информация (цифровая),на основе которой будут рассчитаны показатели, значения которых нужно сохранять с установленной периодичностью (шаг будет в минутах). То как будет выглядеть: http://ifolder.ru/28079471
Макрос:
Private Sub Worksheet_Calculate()
Application.ScreenUpdating = False
Dim cell As Range, newcell As Range, x As Range, CellCopy As Range

For Each cell In Range(КонтролируемыйДиапазон).Cells
Set CellCopy = cell.EntireRow.Cells(Columns.Count)
If cell <> CellCopy Then
' запоминаем новое значение
CellCopy = cell
' ищем соответствующий столбец
Set x = Rows(1).Find(cell.Previous.Value)
If x Is Nothing Then MsgBox "Столбец с показателем " & cell.Previous & " не найден", vbCritical, "Ошибка": Exit Sub
' нашли нужный столбец
Set newcell = x.EntireColumn.Cells(Rows.Count).End(xlUp).Offset(1)
newcell = Now: newcell.Next = cell
End If
Next cell
End Sub

Заранее Огромное Спасибо=)

Добрый день!
Я не программист, но методом проб и ошибок, интенсивным поиском в Интернете удалось создать макрос для замены текста в диаграммах, которые являются частью документов Microsoft Word. Данные диаграммы, насколько я понимаю, являются документами Microsoft Excel. Если неправ, поправьте.

Макрос запускается из Microsoft Word, просматривает документ Microsoft Word, находит диаграммы, открывает их в программе Microsoft Excel, ищет и заменяет нужные слова, но перед автоматическим закрытием документа Microsoft Excel появляется сообщение "Приложению Microsoft Excel не удалось найти данные для замены. Проверьте правильность указания условий поиска и параметров форматирования...". Мне приходится после каждого вызова подпрограммы замены нажимать ОК.

Задаю вопрос в ветке по Excel VBA, так как код, выполняемый в Word, по-видимому делает всё как надо. Подскажите, где копать. Какой такой параметр функции поиска и замены я упустил? Как можно запретить всплывающие окна на время выполнения подпрограммы замены?


Код:
Sub DoFindReplaceE(FindText, ReplaceText)
Cells.Replace What:=FindText, Replacement:=ReplaceText, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
End Sub

Sub ShowWorkbook_Word()
Dim objShape As InlineShape
For Each objShape In ActiveDocument.InlineShapes
If objShape.HasChart Then
objShape.Chart.ChartData.Activate
Call DoFindReplaceE("МТЗ", "MTZ")
Call DoFindReplaceE("РБ", "RB")
'И так далее, Множество подобных строк, где отличаются только документы.
objShape.Chart.ChartData.Workbook.Application.Quit
End If
Next
End Sub

Linguist1979

Если метод DoFindReplaceE чего-нибудь меняет, то чтобы не выскакивало сообщение об ошибке вставьте первой строкой в методе
On Error Resume Next
Если не поможет, надо будет копать в направлении DisplayAlerts = False.

Спасибо за ответ. Пробовал до этого DisplayAlerts = False в начале кода по отдельности и вместе с DisplayAlerts = True в конце. Не помогало.

Нагуглил такое решение.

Код: Sub DoFindReplaceE(FindText As String, ReplaceText As String)
With Worksheets("Sheet1").Range("A:J")
Set c = .Find(FindText, LookIn:=xlValues)
If Not c Is Nothing Then
Cells.Replace What:=FindText, Replacement:=ReplaceText, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
End If
End With
End Sub

Добрый день.
Пишу программку для объединения двух excel книг в одну с суммированием некоторых строк на одном из листе.
Взял код вот отсюда
Сам код [more=тут]

Код:
Dim arr, j%, d%, lngRow&, s$
Dim xl As Excel.Application
Dim oWbk As Excel.Worksheet
Dim FROMROWSCOUNT(6) As Long
Dim FROMCOLSCOUNT() As Integer
Dim sheet_arr
Dim i As Integer

sheet_arr = Array("kccatal", "kcclient", "kcsr", "kcsales", "kcwh", "kcrest")

Set xl = New Excel.Application ' "запустить" Excel

' диалог выбора файлОВ (можно выбрать несколько), результат выбора - в массив
arr = xl.GetOpenFilename("Файл оператора (*.xls), *.xls", 1, "Выбери себе ...", , True)

'If arr <> False Then ' если что-то выбранно
For i = 1 To 6
' ссылка на лист во вновь добавленной книге
Set oWbk = xl.Workbooks.Add.Worksheets(i)
oWbk.Name = sheet_arr(i)
xl.ScreenUpdating = False

FROMROWSCOUNT(i) = xl.Worksheets(sheet_arr(i)).UsedRange.Rows.Count 'количество строк
FROMCOLSCOUNT(i) = xl.Worksheets(sheet_arr(i)).UsedRange.Columns.Count 'количество столбцов

' данные начнем вставлять с первой строки
lngRow = 1

' цикл по всем выбранным книгам
For j = 0 To UBound(arr)
s = arr(j)
d = InStrRev(s, "\")

' формула для "первой" ячейки
' ='Папка_с_книгой[Имя_книги]ЛистОткудаКопируемДанные!'АдресПервойЯчейкиДиапазонаКоторыйКопируем
oWbk.Cells(lngRow, 1).Formula = "='" & Left(s, d) & "[" & Mid(s, d + 1) & "]" & sheet_arr(i) & "'!" & A1

' "протягиваем" формулу вширь и вглубь
w.Range(w.Cells(lngRow, 1), w.Cells(lngRow, FROMCOLSCOUNT(i))).FillRight
w.Range(w.Cells(lngRow, 1), w.Cells(lngRow + FROMROWSCOUNT(i) - 1, FROMCOLSCOUNT(i))).FillDown

' начальная строка для вставки данных из следующей книги
lngRow = lngRow + FROMROWSCOUNT(i)
Next j

' освободить память занятую массивом
Erase arr

' заменить формулы их значениями
w.Range(w.Cells(1, 1), w.Cells(lngRow - 1, FROMCOLSCOUNT(i))).Copy
w.Range(w.Cells(1, 1)).PasteSpecial xlPasteValues

' "загнать" что-то небольшое в буфер обмена
w.Range(w.Cells(1, 1)).Copy

w.Name = "Сравнение" ' переименовать лист
Set w = Nothing ' обнулить ссылку

xl.ScreenUpdating = True
xl.Visible = True ' новая книга!

MsgBox "Ok"
Next i
' Else ' не выбрано ни одного файла
' MsgBox "Не очень-то и хотелось..."
' xl.Quit ' закрыть Excel за ненадобностью
'End If

Set xl = Nothing ' обнулить ссылку

unit4

Цитата:

Код:
FROMCOLSCOUNT(i) = xl.Worksheets(sheet_arr(i)).UsedRange.Columns.Count

Вылетает потому, что

Цитата:

Dim FROMCOLSCOUNT() As Integer

массив не существует
Объяви
Dim FROMCOLSCOUNT(1 To 6) As Integer, например или Redim перед циклом
Код, честно говоря, не читаем, насколько понимаю


Цитата:

For i = 1 To 6
' ссылка на лист во вновь добавленной книге
Set oWbk = xl.Workbooks.Add.Worksheets(i)

создаёт 6 новых книг. Зачем?