» Excel VBA (часть 2)

grooogler
Посмотрите Здесь. В обоих файлах запустите макрос "Main".

Подскажите!
Как узнать имена всех листов в закрытом xls-файле не открывая его?

Цитата:

ERG73

В верхней части этого листа есть ссылка на
Цитата:

Описание Microsoft Excel File Format (eng.)

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

SAS888
очень благодарен. работает.

Если можно ещё пара вопросов.

1. Когда в ячейке длинное содержимое, например 617577130000 оно отображается как 6,18E+11 (и копируется кстати говоря тоже именно так!)... как это отключить (расширение ячейки не помогает)?
ну чтоб было как есть. и ещё когда какая то дата 10.12.2009 ну или типа того, тоже отображается словами...

2. вот допустим я хочу сделать фильтр, чтоб отобразились только строчки содержание
zzz, yyy, zzz. Выбираю Фильтр, потом с столбце меню, Настраиваемый фильтр и т.д. Там в окне только два поля для ввода. (http://s2.ipicture.ru/uploads/090204/ycye2rlbhz.jpg) а можно ли как нибуть сделать чтоб отфильтровать сразу строки по допустим 10 параметрам?
или может быть ктото может скрипт написать.

чтоб допустим есть у меня база:

Лист 1
A B C
11 Bб CCC
22 2Bб 2CCC
33 33Bб 2CCC
44 4 Bб 3 CCC

Лист 2
A B С
22
44

А в третьем листе результат
Лист 3
A B C
22 2Bб 2CCC
44 4 Bб 3 CCC

Ну и соответственно есть в Листе 2, указываю в столбце B чтото, то фильтр идёт по столбцу И

тоесть вот так:

Лист 2
A B С
33
22

Лист 3
A B C
22 2Bб 2CCC
33 33Bб 2CCC


Заранее большое спасибо.

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

Готова, http://slil.ru/26617714
в третьем листе (результат) я так же написал немного поподробнее. надеюсь всё понятно.

p.s. а по первому вопросу?) есть вариант как исправить всякие 6,18E+11 ... ?

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

http://www.appspro.com/Tips/WorkbookTips.htm#WT1

grooogler
Посмотрите Здесь.
Количество столбцов, по которым проводится отбор данных - не ограничено. Т.е. если в таблице на листе 1 много столбцов, то на листе 2 в соответствующих столбцах задайте критерии (тоже неограниченное количество) и запустите макрос.

SAS888
спасибо. работает верно. но видимо мой косяк, я одну деталь не уточнил:
вот мы когда указываем в листе 2 в столбце А: zyx
то в результате у нас должны быть все строчки из листа 1 столбца А которые содержат xyz. А сейчас только первое встречающиеся в результат отправляет.

и ещё небольшое уточнение.
можно ли сделать чтоб в листе результат они выводились не в том порядке в какой строки находятся в Листе 1, а в порядке указания того что мы ищем в Листе 2?
То есть указали мы в Листе 2, столбце А:
222
333
555
И в результате сначала будет идти все строки из листа 1, столбца а - 222, потом все 333, потом 555... и т.д.?

вот пример http://slil.ru/26620781

grooogler
Здесь реализован поиск всех совпадающих позиций.
По поводу сортировки не совсем ясно. Вообще-то должно быть именно так, как Вы написали. Поиск проводится начиная со столбца "A" с первой строки и далее. Берем первое значение, ищем частичные совпадения. При обнаружении, записываем в лист 3 в следующую свободную строку. И т.д. Т.е. именно в таком порядке и будут располагаться данные на результирующем листе. Что не так?

SAS888
а по моему вопросу ничего не решилось ?

Solenaja
Посмотрите Здесь. В исходных файлах отсутствуют столбцы "Итог" и "Средняя продажа". Я не понял, они могут быть, могут не быть? В каком случае что делать? Где они могут быть? Если они есть, включать их в обработку?

SAS888
всё отлично. большое спасибо

Нужна помощь.Мне нужно из макроса открыть xml файл с именем,таким же,как у активного xls файла.Пытался ThisWorkbook.Name - выдает полное имя с .xls , а как бы мне его вычленить без окончания?
Заранее спасибо

Уважаемые, появилась парочка вопросов.
Надеюсь, кто-нибудь знает.

1 - нужно при включенной защите книги (защита ТОЛЬКО на изменение структуры) скрывать и отображать листы Excel.
2 - как запретить обработку сочетания ctrl-break при выполнении макросов.
3 - может ли excel взаимодействовать с word'ом напрямую - т.е. брать данные с ячейки и забивать их автоматом в ворд и нооборот. Или без внешних файлов не обойтись? (т.е. например excel - файл.TXT - word)
4 - дурацкий вопрос, но все же... может как-нибудь можно организовать прокрутку в ЯЧЕЙКЕ. т.к. периодически в одну ячейку нужно ввести оч. много данных, которые даже на экран не всегда влезают. Может у кого какие идеи есть, как это организовать?
5 - и последний. На сколько хватит бедного эксэля при использовании vba? т.е. какой памятью он располагает и не ограничено ли использование глобальных переменных, функций и т.д. Может где-нибудь эту инфу можно почитать?

Прошу прощения,поторопился с вопросом.Решил сам,сделав replace для name.

Цитата:

Нужна помощь.Мне нужно из макроса открыть xml файл с именем,таким же,как у активного xls файла.Пытался ThisWorkbook.Name - выдает полное имя с .xls , а как бы мне его вычленить без окончания?
Заранее спасибо

Mid(ThisWorkbook.Name, 1, Len(ThisWorkbook.Name) - 4)

Добавлено:

SAS888
>Я не понял, они могут быть, могут не быть? В каком случае что делать? Где они могут быть? Если они есть, включать их в обработку?
да это к тому, что если тебе долго заморачиваться с кодом макроса чтобы удалить эти столбцы - то можно не делать (на данный момент они "руками удалены"), а оставлять как есть, но желательно за последней неделей размещать два искомых столбца "Макс" и "Макс / 3", тк таблица может состоять из всего нескольких недель, а искомые значения (Макс и Макс / 3) будут очень далеко справа

в общем то что ты сделал - то что нужно, но
- закрепление области в ячейки С13 не происходит, область закрепляется в других местах, возможно что это из-за Excel 2007. Проверено в 2003 точно также. Закрепление в основном делается на строке 37 и с столбца "P", "R"
- если можно ещё сделать чтобы background ячеек в столбцах "Макс" и "Макс / 3" был таким же как и у ячеек "столбца B", т.е. если строка белая - то и в столбце "Макс" и "Макс / 3" будет тоже белая ячейка, если серая - соотвественно серая.
- где-то было, что лучше для округления использовать функцию Format(), вместо ROUND ()

Доброго времени суток!
Есть такая задача: есть массив чисел и есть число А и число В. Нужно из массива выбрать В-чисел, чтобы их среднее арифметическое было максимально близко к А.
Пока на ум приходит полный перебор.
Может есть какая-то функция, которая бы упростила это?

Solenaja
Еще раз убеждаемся в том, что чем подробнее будет оговорено задание, тем быстрее и точнее получите ответ.
Посмотрите Этот вариант. Сделано следующим образом: если в текущем файле встречаются столбцы с заголовками "Итог" и "Средняя продажа" (названия менять нельзя), то они просто удаляются. После расчета, в сформированных столбцах остаются только значения. Формулы в ячейках уничтожаются. Если же Вы хотите оставить формулы - в коде макроса закомментируйте строку
Код: .Value = .Value

SAS888
совсем забыл, небольшое дополнение к последнему скрипту нужно.
Там скрипт фильтрует содержимое первого листа по значениям содержимого второго и найденное показывает в третьем листе. так вот, нужно чтоб в четвертом листе выводилось всё оставшееся. то есть, там должны вывестись те строки листа 1 которые не соответствуют значениям указанным в листе 2.

Подскажите пожалуйста как сделать так, чтобы не появлялось сообщение:
"Microsoft Office Excel ожидает завершения OLE - операции другим приложением".
Оно появляется когда запускается сложный запрос к базе данных из Excel.
Или как изменить временной интервал, прежде чем оно появится?

grooogler
Посмотрите Здесь. Листы 3 и 4 должны исходно существовать. Макрос их не создает и не проверяет.

Помогите написать к программе пояснения:
Public Sub AddMenu()
Dim comBar As CommandBar
Dim comBarBut As CommandBarButton
Dim mnuXXX As CommandBarControl
Dim N As Long
Dim ii As Long
Set comBar = CommandBars("WorkSheet Menu Bar")
N = comBar.Controls.Count
For ii = 1 To N
If comBar.Controls(ii).Caption = "Matrix" Then Exit Sub
Next ii
Set mnuXXX = comBar.Controls.Add(Type:=msoControlPopup, Temporary:=True, Before:=N)
With mnuXXX
.Caption = "Matrix"
With .Controls.Add(Type:=msoControlButton)
.Caption = "Generate"
.OnAction = "Main"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Clear"
.OnAction = "Clear"
End With
End With
End Sub

Public Sub DelMenu()
Dim comBar As CommandBar
Dim comBarBut As CommandBarButton
Dim N As Long
Dim ii As Long
Set comBar = CommandBars("WorkSheet Menu Bar")
N = comBar.Controls.Count
For ii = 1 To N
If comBar.Controls(ii).Caption = "Matrix" Then
comBar.Controls(ii).Delete
Exit For
End If
Next ii
End Sub
---------------------------------
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const Epsilon As Double = 0.01
Private Const ShowMult As Boolean = True

Private Matrix() As Double
Private tmpMatrix() As Double
Private N As Long
Private NewTMatrix() As Double
Private TMatrix() As Double

Private Pi As Double
Private Row As Long

Public Sub Main()
Dim I As Long
Dim J As Long
Dim L As Long
Dim Amax As Double
Dim p As Double
Dim CosFi As Double
Dim SinFi As Double
Dim IMax As Long
Dim JMax As Long
Dim Iter As Long
Dim pIMax As Long
Dim pJMax As Long
Dim Tii As Double
Dim Tij As Double
Dim Tji As Double
Dim Tjj As Double
Clear
Randomize (Time)
Pi = Atn(1)
N = CLng(InputBox("Введите размерность матрицы." + Chr(10) + "(меньше 20)", "GenerateMatrix", 5))
If N = 0 Then
Row = 2
MyGenerate
Row = Row + N + 1
Else
ReDim Matrix(1 To N, 1 To N) As Double
ReDim tmpMatrix(1 To N, 1 To N) As Double
ReDim TMatrix(1 To N, 1 To N) As Double
'ReDim NewTMatrix(1 To N, 1 To N) As Double
Row = 2
'формируем матрицу
For I = 1 To N
For J = 1 To N
Matrix(I, J) = Rnd(1) * 20
Next J
Next I
End If
Show Row
ActiveSheet.Range("C" + CStr(Row)).FormulaR1C1 = "Исходная матрица"
For I = 1 To N
For J = 1 To N
If (I = J) Or (J = I + 1) Or (J = I - 1) Then Matrix(I, J) = Matrix(I, J) Else Matrix(I, J) = 0
Next J
Next I
Row = Row + N + 3
Show Row
ActiveSheet.Range("C" + CStr(Row)).FormulaR1C1 = "Трехлинейная матрица"
For I = 1 To N
For J = 1 To N - 1
L = Abs(Matrix(I, J + 1) - Matrix(I, J))
If L = 0 Then L = 1
X = Matrix(I, J)

Do While (X <= (Matrix(I, J) + Abs(Matrix(I, J + 1) - Matrix(I, J))))
X = X + Epsilon
tmpMatrix(I, J) = ((1 - X) / L) * Matrix(I, J) + (X / L) * Matrix(I, J + 1)
tmpMatrix(I, J) = X
Loop
Next J
Next I

For I = 1 To N
For J = 1 To N
TMatrix(I, 1) = TMatrix(I, 1) + tmpMatrix(I, J)
Next J
Next I
Row = Row + N + 3
For R = 1 To N
C = 1
ActiveSheet.Cells(R + Row, C + 1).Value = TMatrix(R, C)
Next R
End Sub

Public Sub MultMatrix(FirstMatr() As Double, _
SecondMatr() As Double, _
ResMatrix() As Double)
Dim I As Long
Dim J As Long
Dim K As Long
Dim R As Double
ReDim ResMatrix(1 To N, 1 To N) As Double
'Умножаем матрицу на другую матрицу...
For J = 1 To N
For I = 1 To N
R = 0
For K = 1 To N
R = R + FirstMatr(I, K) * SecondMatr(K, J) ', K)
Next K
If Abs(R) < Epsilon Then R = 0
ResMatrix(I, J) = R
Next I
Next J
End Sub

Public Sub Transp(InputMatrix() As Double)
Dim I As Long
Dim J As Long
For I = 1 To N
For J = I + 1 To N
Swap InputMatrix(I, J), InputMatrix(J, I)
Next J
Next I
End Sub

Public Sub Swap(A As Double, B As Double)
Dim C As Double
C = A
A = B
B = C
End Sub

Public Function Sp() As Double
Dim I As Long
Dim Tmp As Double
Tmp = 0
For I = 1 To N
Tmp = Tmp + Matrix(I, I)
Next I
Sp = Tmp
End Function


Private Sub Show(Row As Long)
Dim R As Long
Dim C As Long
For R = 1 To N
For C = 1 To N
ActiveSheet.Cells(R + Row, C + 1).Value = Matrix(R, C)
Next C
Next R
End Sub

Public Sub Clear()
ActiveSheet.Cells.Select
Application.CutCopyMode = False
Selection.ClearContents
Selection.Interior.ColorIndex = xlNone
Selection.NumberFormat = "0.0000"
Selection.ColumnWidth = 9
End Sub

Private Sub MyGenerate()
Dim I As Long
Dim J As Long
Dim Angle As Double
Dim CosFi As Double
Dim SinFi As Double
Dim IMax As Long
Dim JMax As Long
N = 10
ReDim Matrix(1 To N, 1 To N) As Double
ReDim tmpMatrix(1 To N, 1 To N) As Double
ReDim TMatrix(1 To N, 1 To N) As Double
ReDim NewTMatrix(1 To N, 1 To N) As Double
For I = 1 To N
For J = 1 To N
If I = J Then
Matrix(I, J) = CLng(Rnd(1) * 20)
Else
Matrix(I, J) = 0
End If
Next J
Next I
Show Row
For IMax = 1 To N
For JMax = IMax + 1 To N
For I = 1 To N
For J = 1 To N
If I = J Then
TMatrix(I, J) = 1
Else
TMatrix(I, J) = 0
End If
Next J
Next I

Angle = Rnd(1) * 360
Angle = Angle * 2 * Pi / 360
CosFi = Cos(Angle)
SinFi = Sin(Angle)
TMatrix(IMax, IMax) = CosFi
TMatrix(IMax, JMax) = SinFi
TMatrix(JMax, IMax) = -SinFi
TMatrix(JMax, JMax) = CosFi
MultMatrix TMatrix, Matrix, tmpMatrix
Transp TMatrix
MultMatrix tmpMatrix, TMatrix, Matrix
Next JMax
Next IMax
End Sub

SAS888
гуд. ещё раз спасибо!

SAS888
мегареспект !

p.s. >пришлось после открытия каждого файла разрешать (всего лишь на время выполнения одной функции) обновление экрана. Устроит?
с этим не ясно, рефреш в принципе был и до этого, что замечено, так это чуток медленнее и все.

может быть ещё поправишь вот этот код:

Код: Sub copy_sheets()

Dim arg As String
Dim i As Integer
For i = 1 To Sheets.Count
arg = Sheets(i).Name
If ActiveWorkbook.Sheets(i).Tab.ColorIndex = 14 Then
Sheets(Array("СОДЕРЖАНИЕ", "Скидки", _
arg, "Валюта", "Примечание", "Адрес")).Copy
' сохраняю и закрываю книгу
ChDir "d:\Прайсы\По категориям\..."
ActiveWorkbook.SaveAs (arg)
ActiveWorkbook.Close
' перехожу к поиску следующего зеленого листа
Windows("прод.xls").Activate
End If
Next
End Sub

Уважаемые эксперты.
Вопрос связанный с объединенными ячейками: Есть ли простой способ определить в ВБА, какой диапазон ячеек объединен?

Solenaja
Правильно ли я понимаю Ваш код?
Требуется: по пути "D:\Прайсы\По категориям\" создать файлы, состоящие из 5 фиксированных листов ("СОДЕРЖАНИЕ", "Скидки", "Валюта", "Примечание", "Адрес"), а так же листа с "зеленым" ярлычком. Имя файла должно совпадать с именем "зеленого" листа. Так?
Если так, то можно применить следующий макрос:

Код: Sub copy_sheets()
Dim arg As String, i As Integer, myPath As String
Application.ScreenUpdating = False
myPath = "D:\Прайсы\По категориям\" 'Подставьте требуемый путь для сохранения
For i = 1 To Sheets.Count
arg = Sheets(i).Name
If Sheets(i).Tab.ColorIndex = 14 Then
Sheets(Array("СОДЕРЖАНИЕ", "Скидки", arg, "Валюта", "Примечание", "Адрес")).Copy
ActiveWorkbook.SaveAs (myPath & arg & ".xls"): ActiveWorkbook.Close
End If
Next
End Sub

Help
Очень надо, чтоб при загрузке листа при А2>В2, А3>В3, А4>В4... програма меняла цвет ячейки С2, С3,С4.. на красный?

Voyager69
В модуль нужного листа вставьте код:

Код: Private Sub Worksheet_Activate()

If [A2] > [B2] And [A3] > [B3] And [A4] > [B4] Then [C2:C4].Interior.ColorIndex = 3

End Sub