» Excel VBA (часть 2)

skotov
Ну вот так, как пример
Код класса Class1

Код:
Private WithEvents pApp As Excel.Application
'для новой книги
Private Sub pApp_NewWorkbook(ByVal Wb As Workbook)
Wb.Colors = ThisWorkbook.Colors
End Sub
'для открываемой книги
Private Sub pApp_WorkbookOpen(ByVal Wb As Workbook)
Wb.Colors = ThisWorkbook.Colors
End Sub
'инициализация pApp при создании объекта класса
Private Sub Class_Initialize()
Set pApp = Application
End Sub

AndVGri
Вроде сделал как описано, но все равно не работает, хотя и ошибок не выдает.

Скинул файл на мыло в профайле, который я сохраняю как надстройку и привязываю.

Надеюсь будет возможность посмотреть.

skotov
Извини, я выше уже подправил, не вставил в модуль класса инициализацию pApp

Код:
'инициализация pApp при создании объекта класса
Private Sub Class_Initialize()
Set pApp = Application
End Sub

AndVGri
Мой респект, большое спасибо за помощь!

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

Gretrick
Несколько не оптимально, но на раз в день пойдёт
[more]

Код:
Private Const LastCol As Long = 8&
Private Const CategoryCol As Long = 3&
'Добавить, если надо символы, недопустимые в именах файлов
Private Function SuffixName(ByVal CategoryName As String) As String
CategoryName = VBA.Replace(CategoryName, ":", "_")
CategoryName = VBA.Replace(CategoryName, "/", "_")
CategoryName = VBA.Replace(CategoryName, "\", "_")
CategoryName = VBA.Replace(CategoryName, "*", "_")
CategoryName = VBA.Replace(CategoryName, "?", "_")
CategoryName = VBA.Replace(CategoryName, """", "_")
SuffixName = "_" & CategoryName & ".csv"
End Function

Public Sub SaveAsCsvByCategory()
Dim vLastRow As Long, i As Long
Dim vFirstRow As Long, sCategory As String
Dim pSource As Worksheet, pDestSheet As Worksheet
Dim pDestBook As Workbook, sPrefixName As String

If Not (TypeOf ActiveSheet Is Worksheet) Then
MsgBox "Макрос должен запускаться с рабочего листа", vbExclamation, "Ошибка"
Exit Sub
End If
'Получить путь и префикс csv-файлов категорий
sPrefixName = Application.GetSaveAsFilename("CsvCategory.csv", "CSV Files (*.csv),*.csv")
sCategory = LCase$(sPrefixName)
If (sCategory = "false") Or (sCategory = "ложь") Then Exit Sub
sPrefixName = Mid$(sPrefixName, 1&, Len(sPrefixName) - 4&)

Application.ScreenUpdating = False
'Если строка заголовков полная, то за комментируй строку ниже
Range("A3:H3").Value = Array("Id", "Code1", "Category", "Producer", "Name", "Code2", "Price1", "Price2")
'Сортируем по категриям
Range("A3").CurrentRegion.Sort Key1:=Range("C4"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Инициализация перед разбором по категориям
vLastRow = Range("A3").CurrentRegion.Rows.Count + 2&
sCategory = CStr(Cells(4&, CategoryCol).Value)
vFirstRow = 4&: Set pSource = ActiveSheet
For i = 4& To vLastRow 'собственно, цикл разбора
If CStr(Cells(i, CategoryCol).Value) <> sCategory Then
'Сохраняем данные категории
Set pDestBook = Workbooks.Add
Set pDestSheet = ActiveSheet 'В предположении, что не шаблона с активной диаграммой
pSource.Activate
Range("A3:H3").Copy pDestSheet.Range("A1")
Range(Cells(vFirstRow, 1&), Cells(i - 1&, LastCol)).Copy pDestSheet.Range("A2")
pDestBook.SaveAs Filename:=sPrefixName & SuffixName(sCategory), _
FileFormat:=xlCSV, CreateBackup:=False
pDestBook.Saved = True: pDestBook.Close SaveChanges:=False
vFirstRow = i: sCategory = CStr(Cells(i, CategoryCol).Value)
End If
Next i
'Сохраняем данные последней категории
Set pDestBook = Workbooks.Add
Set pDestSheet = ActiveSheet 'В предположении, что не шаблона с активной диаграммой
pSource.Activate
Range("A3:H3").Copy pDestSheet.Range("A1")
Range(Cells(vFirstRow, 1&), Cells(vLastRow, LastCol)).Copy pDestSheet.Range("A2")
pDestBook.SaveAs Filename:=sPrefixName & SuffixName(sCategory), _
FileFormat:=xlCSV, CreateBackup:=False
pDestBook.Saved = True: pDestBook.Close SaveChanges:=False

Application.ScreenUpdating = True
End Sub

AndVGri
Есть небольшая проблема. Я как первый раз запустил этот макрос. Он около 50 раз ругался, что файл уже существует и затирал уже записанный товар. Проверял по категории "LCD32" там раза в 2 меньше было товаров.

Gretrick
Ну, так в чём проблема? Ужель нельзя сохранить результат в другой папке или изменить префикс файлов результата?

AndVGri
Так я и сохранаю все в пустую папку.

Gretrick
Ну, не знаю, тогда
Специально прогнал твой тестовый файл по папкам D:Temp\1 и D\Temp2, префикс по-умолчанию в обоих случаях CsvCategory. Всё без проблем. Если только ты сам чего не менял в макросе.
Диалог же на сохранение позволяет выбрать место и префикс для файлов результата. По каким местам сохранял? И на какой путь и имя файла ругается Excel? На один и тот же, вне зависимости от выбора?

AndVGri
Не зависимо от папки куда я сохраняю через 3 файла ругается на то, что CsvCategory_Cables_ connections.csv файл существует.

Gretrick
Скинь мне на мыло в профиле файл, на котором ругается, посмотрю. Для страховки в цикле поменяй

Код:
If CStr(Cells(i, CategoryCol).Value) <> sCategory Then

Доброе время суток!
Хочу подключить к своему приложению файл Help (работаю в Excel). Посмотрел Help Excel, пишу у себя в программе:
'
Public Sub aaa()
Application.Help "C:\1\NP.hlp",61
End Sub

СТранно, толи он глючит толи работает нестабильно. Так вот при загрузке возникали следующие ситуации:
1. НИчего не происходило: гружу код выполняется, ошибок нет, но файл не загружается
2. Выдает ошибку, что такого ID нет
3. Выдает сообщение "Настройка поиска"

Как же быть? HElp компилировал программой Help&manual в двух фариантов *.chm и *.hlp -ничгео не меняется....Как же быть?

robinLib
Да, нет работает (проверял на hlp)
Скорее всего ты в Help&Manual не назначил ContextID (уникальный номер) разделам справки. Если у тебя 4 версия (в других не знаю) прогони Tools/Help Context Tool с опцией Assign New Context Numbers To Topics, ну, или можешь ручками расставить. Для того, чтобы сохранить существующие ContextID и Topic в справке в файл, там же выполни с опцией Export Help Context Numbers

AndVGri


Спасибо огромное! Теперь работает!

меня попросили помоч, а я попрошу вас(просто я не очень знаю VBA) если можете, суть такая:
надо сделать что-то типа словаря,задача стоит такова:
На листку MS Exel в два столбца записано слова одного языка(столбец А) а в другом(столбец Б) их перевод. Надо сделать программу VBA, какая бы позволяла получать перевод набранного слова(текстбокс1) (с языка А в язык Б и наоборот с языка Б в язык А). на форме надо разместить полный список слов(листбокс1)(языка которого мы выберем) будет например 2 оптионбаттон с помощью каких мы сможем выбрать с какого на какой язык переводим. И что самое для меня тяжелое это предвидеть выбор слова из списка(листбокс1) и автоматической смены позиции в списке(листбокс1) в соотвецтвенно к слову(или его фрагмента) при смене текста в поли листбокс1, перевод выводить в текстбокс2.

Кто-то чем-то может помогти???

Не могу составить макрос для Excel. Бьюсь головой уже неделю.

Дано:

носки 45
трусы 43
штаны 75
майки 28
шубы 67
чай 56
кофе 54
сало 32


на машину помещается максимум 150 вещей. Нужно чтобы макрос брал из этого списка вещи и сортировал по 150 штук (по машинам), разбивая остаток на следующую машину.

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

Машина 1:

носки 45
трусы 43
штаны 62

Машина 2

штаны 13
майки 28
шубы 67
чай 52

Машина 3

чай 4
кофе 54
сало 32

Есть у кого-нибудь идея как проще всего это осуществить.

Заранее спасибо.

Sub AddCommandBarAndButton()
'
' AddCommandBarAndButton Macro
' Macro created 21.03.01 by Kolesov Andrei
'
Dim myBar As CommandBar
Dim myControl As CommandBarButton

' Создание панели инструментов
Set myBar = ActiveDocument.CommandBars.Add(Name:="MyNewBar", _
Position:=msoBarTop, Temporary:=True)
With myBar
.Visible = True
.RowIndex = msoBarRowLast
End With
' Создание кнопки
Set myControl = myBar.Controls.Add _
(Type:=msoControlButton, Before:=1)
With myControl
.Caption = "Новая_Кнопка"
.OnAction = "MyNewMacro"
.FaceId = 16
.Style = msoButtonIconAndCaption
End With
End Sub
Почему-то данный макрос выдает ошибку при выполнении. В чём косяк?

MORB_id
А ты место не перепутал?

Цитата:

ActiveDocument.CommandBars.Add

Это для Word
Для Excel будет ActiveWorkbook.CommandBars.Add...

MORB_id
честно говоря, не припомню, чтобы у ActiveDocument была коллекция CommandBars. Если я правильно понял, тебе нужен объект Application:

Код: Application.CommandBars.Add

The okk
Тут ты не прав, есть панели как и в приложениях Office, так и вложенные панели в документах. Document для Word и Workbook в Excel обладают свойством CommandBars

AndVGri

Цитата:

Тут ты не прав, есть панели как и в приложениях Office, так и вложенные панели в документах. Document для Word и Workbook в Excel обладают свойством CommandBars

Я не сказал, что нет такого свойства! Я лишь сказал, что такой коллекции не существует. Т.е. если обратиться к свойству Книги .CommandBars оно вернет Nothing, что означает наличие свойства, но отсутствие коллекции. Nothing не обладает методом .Add (и вообще методами), поскольку это не объект.

У тебя что-то есть в этом свойстве?

The okk
Увы, ты прав, более того, вложенная панель в книгу не доступна. Как пишется в Excel VBA

Цитата:

There is no programmatic way to return the set of command bars attached to a workbook.

Хотя я пример MORB_id проверял в Word, там без проблем
В отладке ?ActiveDocument.CommandBars Is Nothing, возвращает False. Потому, по аналогии и написал для Excel.
Видимо, такой "единообразный" подход к приложениям Office у Microsoft

AndVGri
Ясно. Только не пойму, почему тогда у MORB_id возникли ошибки. Разве что он вордовый макрос попытался в Excel запустить...
Да, с "единообразными" подходами мелкие мягкачи намудрили.

может хоть кто-то подскажет!!!!!!!!!!!!
Хоть чем-то!!!!!!!!!

Artcv
Не знаю, как AndVGri, но писать писать софтину с нуля лично мне как-то не хочется. Скажи, что именно непонятно, в чем проблемы, выложи кусок кода, который не работает - подскажу, как исправить. А на написание словаря и рисование форм уйдет много времени, которого у меня на данный момент просто нет.

Artcv

Цитата:

Хоть чем-то!!!!!!!!!

Private Sub ListBox1_Click()
MsgBox ListBox2.List(ListBox1.ListIndex)
End Sub

AndVGri

Цитата:

Private Sub ListBox1_Click()
MsgBox ListBox2.List(ListBox1.ListIndex)
End Sub

Класс! Скромненько и со вкусом. Отсутствие Scripting.Dictionary радует глаз Хорошая мысль.
А текстбокс тогда вообще не нужен.

The okk

Цитата:

Отсутствие Scripting.Dictionary радует глаз

А он то тут зачем?
А что нужно присвоить TextBox1.Text, пусть попробует не догадаться

AndVGri

Цитата:

А он то тут зачем?

просто теоретически задача сводится к:
1. зафигачить все в словарь (Dictionary): ключи - слова первого языка, Items - слова второго языка
2. цикл пока не надоест:
ввести инпутбоксом слово
Если Словарь.exists то
найти по введенному слову в словаре Item, msgbox этого Item
Иначе
msgbox "Слово не найдено" (если усложнить, можно еще и вопрос задать - добавить в словарь? и если да, то InputBox с запросом перевода и добавить слово в Dictionary)
Конец Если
Конец Цикла
И без форм. И без текстбоксов.
При желании можно еще навесить на одну из кнопок месседжбокс, выводящий либо все ключи словаря, либо все Items словаря (это вместо листбоксов).
Но это конечно упрощенный вариант для двух языков.