» Excel VBA (часть 2)

Помогите плиз.
есть у меня список льготников около 6000. необходимо выбрать из них указанное количество человек (допустим 500, но так чтоб с каждой буквы алфавита бралось одинаковое кол-во фамилий) и все выбранное скопировать в другую страницу. Но надо чтоб макрос проверял фамилии чтоб не повторялись. чтоб можно было вставить новый список льготников и выбрать заного еще людей к отобраному списку.
В програмировании разбераюсь немного а вот в VBA еще не работал и не могу сообразить.

Вопро по работе в окне написания кода макроса, мне очень неравиться то как он мне мешает писать коментарии удаляя постоянно пробелы, как это отключить?

Troitsky

Цитата:

Если интересно могу и тут код выложить.

А то.
Кто ж против будет.

ProgrBoris2007
А что если фамилий, которые начинаются с буквы "Я" всего 1-2, а остальных по 300-400?
Выводить по 1-2 фамилий с каждой буквы?

SERGE_BLIZNUK
Спасибо за помощь и за пример. Пытался разобратся и вот что из этого вышло(мне кажется работает хорошо).

Код:
Sub TestDict()
Dim pAll As New Scripting.Dictionary
Dim WE As Worksheet, WM As Worksheet
Dim rowLast, iRow As Long, z As Integer, vEntry As String
Set WE = Worksheets("Eliminar")
Set WM = Worksheets("MENU")
WE.Select
rowLast = Cells(WE.UsedRange.Rows.Count + 1, "A").End(xlUp).Row
' сохраним весь столбец А в Scripting.Dictionary для удобства поиска
For iRow = 1& To rowLast
vEntry = CStr(WE.Cells(iRow, "A").Value)
If Not pAll.Exists(vEntry) Then
pAll.Add vEntry, iRow
End If
Next iRow
' в результате этого кода в Dictionary получаются все уникальные строки из
' столбца А
WM.Select
FinalRowM = Range("A65536").End(xlUp).Row
For z = FinalRowM To 2 Step -1
For iRow = 0 To rowLast - 1
If Cells(z, 1).Value = pAll.Keys(iRow) Then
Cells(z, 1).EntireRow.Delete
End If
Next iRow
Next z
' сверяет со списком "pAll.Keys" и если есть одинаковые, удаляет
End Sub

PavelO
Там на всех буквах много фамилий. Впринципе неважно если если гдето фамилий будет меньше гдето больше. Главное чтоб макрос выбрал нужное количество человек. Вручную выбирать займет месяц. Помогите плиз

ProgrBoris2007

Цитата:

Там на всех буквах много фамилий

;-)))

1) уникальный код у Ваших льготников есть!? Если нет - ОЧЕНЬ рекомендую завести.
Полные тёзки (фамилия+имя+отчество) встречаются намного чаще, чем можно себе представить!
2) алгоритм я вижу приблизительно такой - проходим по всем фамилиям, считаем кол-во каждой буквы, потом обрабатыаем полученный массив из 33 элементов, получая, сколько нужно людей каждой фамилии и уже потом выбираем
либо так:
общее количество := 0;
пока общее количество < 500
берём по одному человеку каждой фамилии (по циклу от "A" до "Я")

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

3) и последнее, очень рекомендую в списке людей завести поле - отметку, кого уже выбрали (или, например, дату, когда сформировали выборку, в которую он попал!)

ProgrBoris2007
'Этот код проверяет достаточно ли фамилий с каждой буквы для 500 человек, если недостаточно выдаст сообщение
Private Sub CommandButton1_Click()
Dim FFArr(), KolFFArr()

Kol_vo = 501 'кол-во, которое нужно вывести
KolFF = 0
ReDim Preserve FFArr(0)
ReDim Preserve KolFFArr(0)

For i = 1 To UsedRange.Rows.Count
ZapFF = True 'запись первой буквы фамилии разрешена
'Пробегаем по всем записанным буквам
For cFF = LBound(FFArr) To UBound(FFArr)
'cells(i,1) - i -строка, 1-столбец с фамилией
If FFArr(cFF) = Left(Cells(i, 1), 1) Then
ZapFF = False 'если первая буква уже встречалась, то запись запрещена
KolFFArr(cFF) = KolFFArr(cFF) + 1 'и прибавляем 1
End If
Next
If ZapFF = True Then
KolFF = KolFF + 1
ReDim Preserve FFArr(KolFF - 1) 'меняем размерность
FFArr(KolFF - 1) = Left(Cells(i, 1), 1) 'записываем первую букву
ReDim Preserve KolFFArr(cFF)
KolFFArr(cFF) = 1 'Кол-во данных букв = 1
End If
Next

Kol_1 = Kol_vo / KolFF 'столько нужно взять фамилий от каждой первой буквы
For cFF = LBound(FFArr) To UBound(FFArr)
If Kol_1 > KolFFArr(cFF) Then
MsgBox "Фамилий на букву ''" & FFArr(cFF) & "'' всего " & KolFFArr(cFF) & ", а рекомендуется " & Kol_1

End If
Next
End Sub

Такой вопрос: Фамилии должны выбираться случайно или первые 30 предположим

Добавлено:
SERGE_BLIZNUK

Цитата:

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

А что фамилии на "ь" и "ъ" тоже бывают? ))

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

invisible17
application.screenupdating=false
пойдет?

Но я бы еще посоветовал, н-р, при копироваии данных из лист в лист применять
Application.Calculation =xlCalculationManual

Не забудь потом этот режим включить
Application.Calculation = xlCalculationAutomatic

to Olive77

Спасибо, именно то, что нужно!

Application.Calculation применяю, но хочется ещё хоть немного быстрее... вот и решил ещё и демонстрацию отключить.

Добавлено:
Ещё один вопрос:

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

Dim fwb As Workbook
Dim wb As Workbook
Dim sh As Worksheet

Set fwb = Excel.Application.Workbooks.Open("C:\Analis\Reports\Current\oBalance_m_OF.xls")
Set wb = ActiveWorkbook
Set sh = wb.Worksheets(CStr("ОФ"))
sh.Activate

fwb.Close False
Excel.Application.Quit
Set fwb = Nothing
Set wb = Nothing
Set sh = Nothing

При этом, если я "убиваю" Excel в процессах вручную, то при запуске макроса появляется ошибка 462: the remote server machinedoes not exist or is unavaliable.
После остановки макроса и повторного запуска данной ошибки нету.

Может я как-то неправильно открываю (закрываю)?

Каким образом реализовать задачу:

Есть много файлов Excel (имена разные)
Имя листа в файле совпадает с именем файла.
Таблицы файлов одинаковые по формату но значения в них разные.

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

Знаю, что можно использовать функцию =СУММ(), где в качестве аргументов использовать ссылку на книгу_лист_ячейку, а потом потянуть за правый нижний угол. Но все осложняется тем, что файлов много очень, а формула может быть только 1024 знака.
Желательно, если в макросе не придется прописывать имена файлов (все они лежат в одной папке)

CEMEH

Цитата:

Как получить лист с суммированием значений всех файлов

значений, наверное, всё таки ячеек? А каких именно? Я предполагаю, что в конце таблицы есть ряд сумм ("Итого:") - вот эти суммы по всем файлам и надо сложить?
Или вообще ВСЕ значения по строкам и столбцам ?


Цитата:

осложняется тем, что файлов много очень

Время работы будет очень большим. Основные затраты пойдут на - открытие/закрытие всёх файлов. Бывает, что один файл (правда большой) Excel почти полминуты открывает... ;-((

SERGE_BLIZNUK
Не все так просто
столбец А:А даты возрастание
строка А1:1 параметры

В итоге надо получить сводную таблицу, в которой В3=сумма всех ячеек В3 всех файлов в папке
Аналогично А4, А5 и так далее.

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

invisible17

Цитата:

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

Лучше сначала присвоить переменной ссылку на объект Excel.Application, и только затем пользовать его методы. По окончании освободить ссылки обычным образом:

Код: Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("c:\temp.xls")
' <...>
objWorkbook.Close SaveChanges:=False
Set objWorkbook = Nothing
Set objExcel = Nothing

PavelO
впринципе без разницы как они выбираются. можно и случайно. Главное чтоб никого не обидеть
Эти льготники получат бесплатное стоматологическое лечение.
У каждого льготника присутствует уникальный паспортный номер и номер страхового полиса.

Добавлено:
PavelO
при проверке достаточно ли фамилий на буквы, у меня находит на буквы Щ, Э -мало фамилий. Можно сделать чтоб он брал тех что есть, а остальное из других букв.

Понадобилось мне несколько документов с примечаниями перевести в текстовый формат.
При простом сохранении в формат с разделителями примечания не сохраняются.
Решил добавить их отдельным столбцом, но столкнулся с проблемой переноса примечаний в значения ячеек (вариант специальной вставки примечаний не помог).
Попробовал написать скрипт на VBA, но попытка записать макрос проблему не решила - универсального варианта копирования комментария в значение ячейки там не оказалось.
Помощь тоже до конца проблему не решила.
То есть я понял, как:
1. Получить значение примечания;
2. Удалить примечание;
3. Вставить из буфера.

А вот поместить значение в нужную ячейку/буфер так и не получилось

Вот такой код не работает:

Код: Sub Макрос1()
Selection.Text = Selection.Comment.Text
' Selection.ClearComments
End Sub

Помогите доделать задачу

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

У меня 2 проблемы.
1. Постоянно ругается .ActiveDocument.SaveAs Filename:=strOutFileName Причем я удаляла файлы из папки, все равно на этой строке дает ошибку.
2. Как из макроса Экселя создать таблицу в ворде. Хотелось бы выводить часть информации не по строчно, а в таблице.
Ниже приведен код.


Private Sub CommandButton1_Click()
Dim intReportCount As Integer ' Количество сообщений
Dim strForWho As String ' Получатель сообщения
Dim strSum As String ' Рабочее место
Dim strProduct As String ' Отдел
Dim strOutFileName As String ' Имя файла для сохранения сообщения
Dim strMessage As String ' Текст дополнительного сообщения
Dim rgData As Range ' Обрабатываемые ячейки
Dim rngCell As Range
Dim objWord As Object
Dim i As Integer


' Создание объекта Word
Set objWord = CreateObject("Word.Application")

' Информация с рабочего листа

' rngCell = Application.ActiveCell
Dim cur_range As Range
With ActiveSheet
Set cur_range = Selection
cur_range.Activate
End With

Set rgData = cur_range
'strMessage = Range("AC" & l)

' Просмотр записей на листе Лист1
intReportCount = Application.CountA(Range("A:A"))
For i = 1 To intReportCount
' Динамические сообщения в строке состояния
Application.StatusBar = "Создание сообщения " & i

' Назначение данных переменным
strForWho = rgData.Cells(i, 1).Value
strProduct = rgData.Cells(i, 2).Value
strSum = rgData.Cells(i, 3).Value
'ThisWorkbook.Path & "\" & strForWho &
' Имя файла для сохранения отчета
strOutFileName = ThisWorkbook.Path & "\" & strForWho & ".doc"
' Передача команд в Word
With objWord
.Documents.Add
With .Selection
' Заголовок сообщения
.Font.Size = 14
.Font.Bold = True
.ParagraphFormat.Alignment = 1
.TypeText Text:="Инвентаризационная карточка пользователя"
.TypeParagraph
.TypeParagraph
.Font.Size = 14
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.TypeText Text:="ФИО" & vbTab & strForWho
' Отправитель
.TypeParagraph
.TypeParagraph
.TypeText Text:="Рабочее место" & vbTab & strProduct
' Сообщение

'.TypeText strMessage

.TypeParagraph
.TypeParagraph
' Название подразделения
.TypeText Text:="Подразделение" & vbTab & strSum
.TypeParagraph
.TypeParagraph
.Font.Size = 14
.Font.Bold = True
.ParagraphFormat.Alignment = 1
.TypeText Text:="Технические характеристики ПК"


.TypeParagraph
.TypeParagraph
.Font.Size = 14
.Font.Bold = True
.ParagraphFormat.Alignment = 1
.TypeText Text:="Программное обеспечение ПК"



'Format(strSum, "$#,##0")
End With
' Сохранение документа

.ActiveDocument.SaveAs Filename:=strOutFileName
End With
Next i

' Удаление объекта Word
objWord.Quit
Set objWord = Nothing

' Обновление строки состояния
Application.StatusBar = False
' Вывод на экран информационного сообщения
MsgBox intReportCount & " заметки создано и сохранено в папке " _
& ThisWorkbook.Path
End Sub

AndVGri


Цитата:

Как можно cкопировать множественный диапазон в него же (я хочу скопировать формулы и вставить значения)?

Цитата:

Так кто мешает?
pUnion.Copy
pUnion.PasteSpecial ...

у меня почему-то выдает ошибку-(
вот мой скрипт:

Sheets("1").Select
Dim pUnion As Range
Set pUnion = Application.Union(Range("C1:C4"), Range("B3:B8"), Range("A9,A7"))
pUnion.Copy
pUnion.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Всем привет!
Помогите пожалуйста решить задачу. Мне нужно использовать в VBA функции аналогичны функциям Exel "Найти","ДЛСТР","ЗАМЕНИТЬ","СЖПРОБЕЛЫ","ЗНАЧЕН". Если можна так выразится, перевести их на язык VBA.

KChernov
Цитата:

вот поместить значение в нужную ячейку/буфер так и не получилось

работает код:
Selection.Value = Selection.Comment.Text

---

ferias

Цитата:

Мне нужно использовать в VBA функции аналогичны функциям Exel "Найти","ДЛСТР","ЗАМЕНИТЬ","СЖПРОБЕЛЫ","ЗНАЧЕН".

Application.WorksheetFunction.<нужная функция>

например, для "СЖПРОБЕЛЫ"
Dim Res As String
Res = Application.WorksheetFunction.Trim(" пример вот такой ")
MsgBox ">" & Res & "<"

соответствие русских<->английских названий формул смотри шапку или файлик
"C:\Program Files\Microsoft Office\OFFICE11\1049\funcs.xls"

и ещё, рекомендую ознакомится со стайкой (малюсенькой) Calling Worksheet Functions In VBA


Добавлено:

KChernov
да, забыл сказать - проверяется, есть ли примечание - вот так:
If Cells(iRow, ColSource).Comment Is Nothing Then
' ну нет тут примечания
MsgBox "Not found comments!"
else
....

и ещё. несколько страниц назад я писал код по обработке ячеек с примечаниями...
можете полистать-почитать... ;-)))

Какая используется команда для открытия файла эксель?
Workbooks.OpenText Filename:="H:\File.xls"
Sheets("list").Select
???

ol7ca
может я неправильно понял вопрос...
а разве так не получается ?
Workbooks.Open Filename:="H:\File.xls"

ol7ca
Похоже придётся делать циклом. Не хочет Excel копировать не равные диапазоны

Код:
Sheets("1").Select
Dim pUnion As Range, pCell As Range
Set pUnion = Application.Union(Range("C1:C4"), Range("B3:B8"), Range("A9,A7"))
For Each pCell In pUnion
pCell.Value = pCell.Value
'или, для копирования формул
'pCell.Copy
'pCell.PasteSpecial ....
Next pCell

ProgrBoris2007
Вот код, который копирует фамилии. Разбирайтесь на здоровье. Так как я ограничен по времени, то код несколько убогий, но в целом функционирует:
Private Sub CommandButton1_Click()
Dim FFArr(), KolFFArr(), KolLast(), rowNum(), rowNum2()

Kol_vo = 101 'кол-во, которое нужно вывести
KolFF = 0
ReDim Preserve FFArr(0)
ReDim Preserve KolFFArr(0)
ReDim Preserve KolLast(0)
ReDim Preserve rowNum(33, 0)
y = 0

For i = 1 To UsedRange.Rows.Count
nachalo:
Set proverka = Sheets("Лист2").Columns("a:a").Find(Cells(i, 1)) 'проверяем не встречается ли эта фамилия на Листе2 в столбце a
If Not proverka Is Nothing Then 'если фамилия встречается - проверяем другие столбцы
If Sheets("Лист2").Cells(proverka.Row, 2) = Cells(i, 2) And Sheets("Лист2").Cells(proverka.Row, 3) = Cells(i, 3) Then
If i = UsedRange.Rows.Count Then
Exit Sub
End If
i = i + 1
GoTo nachalo 'выходим из цикла
End If
End If
ZapFF = True 'запись первой буквы фамилии разрешена
'Пробегаем по всем записанным буквам
For cFF = LBound(FFArr) To UBound(FFArr)
'cells(i,1) - i -строка, 1-столбец с фамилией
If FFArr(cFF) = Left(Cells(i, 1), 1) Then
ZapFF = False 'если первая буква уже встречалась, то запись запрещена
KolFFArr(cFF) = KolFFArr(cFF) + 1 'и прибавляем 1
If maxKol < KolFFArr(cFF) Then
ReDim Preserve rowNum(33, KolFFArr(cFF))
End If
rowNum(cFF, KolFFArr(cFF)) = i
If maxKol < KolFFArr(cFF) Then maxKol = KolFFArr(cFF)
End If
Next
If ZapFF = True Then
KolFF = KolFF + 1
rowNum(KolFF - 1, 0) = i
ReDim Preserve FFArr(KolFF - 1) 'меняем размерность
FFArr(KolFF - 1) = Left(Cells(i, 1), 1) 'записываем первую букву
ReDim Preserve KolFFArr(cFF)
KolFFArr(cFF) = 1 'Кол-во данных букв = 1
End If
Next

i = 0
ReDim Preserve KolLast(UBound(FFArr))
For cFF = LBound(FFArr) To UBound(FFArr)
KolLast(cFF) = Int(Kol_vo / KolFF)
Next
For cFF = LBound(FFArr) To UBound(FFArr)
line2: If i > UBound(FFArr) Then
i = 0
End If


If Kol_vo / KolFF <> Round(Kol_vo / KolFF, 0) And KolFFArr(cFF) > Round(Kol_vo / KolFF, 0) Then
If KolFFArr(i) > Round(Kol_vo / KolFF, 0) Then
KolLast(i) = KolLast(i) + 1
Kol_vo = Kol_vo - 1
End If
i = i + 1
GoTo line2:
ElseIf KolFFArr(cFF) < Round(Kol_vo / KolFF, 0) Then
KolLast(cFF) = Round(Kol_vo / KolFF, 0)
Do While KolFFArr(cFF) <> KolLast(cFF)
KolLast(cFF) = KolLast(cFF) - 1
line: If i > UBound(FFArr) Then
i = 0
End If
If KolLast(i) < KolFFArr(i) Then
KolLast(i) = KolLast(i) + 1
i = i + 1
Else
i = i + 1
GoTo line
End If
Loop
End If
Next
If Sheets("Лист2").Cells(1, 1) <> "" Then
Z = Sheets("Лист2").Cells(1, 1)
Else
Z = 2
End If
For i = LBound(KolFFArr) To UBound(KolFFArr)
r = 1
For y = 0 To KolFFArr(i)
If rowNum(i, y) <> Empty Then
If r > KolLast(i) Then
Exit For
End If
Sheets("Лист2").Cells(1, 1) = Z - 1
Sheets("Лист2").Cells(Z, 1) = Cells(rowNum(i, y), 1)
Sheets("Лист2").Cells(Z, 2) = Cells(rowNum(i, y), 2)
Z = Z + 1 ' строка на Листе2, в которую будем записывать
r = r + 1 'счетчик кол-ва записей на каждую букву
End If
Next

Next
End Sub

SERGE_BLIZNUK
Спасибо, все получилось
Код тоже нашел - посмотрю.

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

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

SERGE_BLIZNUK

Спасибо, все открылось

Добавлено:
AndVGri

Спасибо, я попробую

all
Подскажите, как, решить.
Есть столбец с датами - Срок годности. К ячейкам столбца применяется условное форматирование - используется функция СЕГОДНЯ(), со значением которой сравнивается значение ячейки, и в зависимости от результата сравнения ячейки окрашиваются в разный цвет. Столбец заполняется регулярно, а функция СЕГОДНЯ() не обновляется постоянно - т.е. ячейки сохраняют тот цвет, который был у них на момент ввода. Если по ячейке кликнуть два раза, то функция пересчитается, учитывая новое значение СЕГОДНЯ(), и красится в нужный цвет. Как сделать, чтобы ячейки пересчитывались автоматически, т.е. сравнивались с СЕГОДНЯ() каждый раз, когда открывается книга?
Может, подскажите код макроса, который бы брал значение ячеек из столбца, сравнивал его с СЕГОДНЯ() и вставлял обратно.

Подскажите, плз, как можно:
-открыть файл
-при открытии мои файлы спрашивают "обновить?" - сделать отбой на обновления
-распечатать отчет из книги 1 (параметры печати уже настроены)
-распечатать отчет из книги 2
-закрыть файл без сохранения
-открыть следующий файл
...

спасибо

SERGE_BLIZNUK
Спасибо за помощь.