» Excel VBA (часть 2)

LerOK777
Смотря что Вы собираетесь дальше делать с этой ссылкой. Широкие возможности работы с файлами и папками можно реализовать через FileSystemObject.

Добавлено:
XOPEK HAPKOMAH
Если требуется выбрать несколько файлов (не открывать), то можно использовать, например код

Код: Sub SelectFiles()

Dim i As Integer, Msg As String
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = "C:\"
.Title = "Select File(s)"
.Show
If .SelectedItems.Count = 0 Then Exit Sub

For i = 1 To .SelectedItems.Count
Msg = Msg & .SelectedItems(i) & vbCrLf
Next

MsgBox Msg
End With

End Sub

SAS888
О да, это то что надо!

отвечаю на вопрос, заданный в другой теме

Цитата:

Хотелось бы создать специальную кнопочку на первом(главном)листе-удаление пустых строк.Чтобы после занесения новых данных из EXCEL заявки в EXCEL таблицу,гажать на нее и удалить все пустые ненужные строки.И автоматически сформировалось бы нужное количество остальных листов...
но как написать такое макрос?Как он будет считать какие именно пустые ....может,по первым трем столбцам(Ф.И.О.)проверяет их.если пучтсые,то удаляет всю строку...

Написать такой макрос не сложно. Но, считать, какие именно пустые (на Ваш взгляд ;-) — решать именно Вам... я, если честно, не понимаю, почему надо пустые строчки удалять - их же 65 тысяч :-))
и листы создавать - имена какие им давать - по ФИО? или просто "Лист 2", "Лист 3" ... ?
и последнее - было бы неплохо, если бы выложили пример Вашего XLS файла (лучше запакованного) на какой-нибудь хостинг (rapidshare.com, ifolder.ru, zalil.ru, mytempdir.com), а сюда опубликовали ссылочку на выложенный пример...

вот ссылка на файл:
http://ifolder.ru/7272201
Конкретно в моем файле имеется 20 готовых строк,а введено всего 19 человек.(Т.е. мы можем ввести и меньшее количество людей,соответственно будет больше лишних пустых строк)Как я понимаю,нужно удалять пустые только в этом пределе.Допустим,что будет проверяться на наличие в ячейках ФИО,если таковые отсутствуют,то эта строка считается пустой и удаляется.
Листы без названий.Каждый лист соотвествует каждому человеку в списке на первом листе.Вот.

Добавлено:
Да!Для снятия защиты со страниц пароль-"kk"(на английском)
...спасибо.

Nika7
Удалить пустые строки в оговоренном Вами диапазоне можно, например, выполнив макрос

Код: Sub DelRows()

Dim x As Range, i As Long
Application.ScreenUpdating = False
With Sheets("D")
Set x = .Cells.Find(what:="ИТОГО:", LookAt:=xlWhole)
For i = x.Row - 2 To 8 Step -1
If .Cells(i, "B") = "" Then .Rows(i).Delete
Next
End With

End Sub

Здравствуйте, помогите, плиз, решить такую задачку:
Есть список файлов Excel, в каждом из них необходимо найти (во втором столбце) строку "От Имя Контрагента", и справа от неё еще одну такую же, потом из обеих строк вырезать "От ", найти строку, начинающуюся на "Мы, нижеподписавшиеся" (она выше) и заменить её на сборку из 3 констант и имён контрагентов. Пока что получилось следующее "чудо", в котором не могу запустить поиск.



Код: Sub AktRemake()
Const str1 = "Мы, нижеподписавшиеся, _______________ "
Const str2 = " _______________________, с одной стороны, и ________________ "
Const str3 = " _______________________, с другой стороны, составили настоящий акт."
Dim contr1 As String
Dim contr2 As String
Dim FileList As Variant
Dim wbCurrent As Workbook
Dim shCurrent As Worksheet
Dim i As Integer

On Error GoTo 0
With Application
FileList = .GetOpenFilename("Excel Files (*.xls), *.xls", , "Выберите файлы", , True)
If Not IsArray(FileList) Then End
End With

For i = LBound(FileList) To UBound(FileList)
Set wbCurrent = Workbooks.Open(FileList(i), ReadOnly:=False)
For Each shCurrent In wbCurrent.Worksheets


Next

wbCurrent.Save
wbCurrent.Close
MsgBox FileList(i)
Next



End Sub

SAS888, Дело в том, что нужно получить данные из ячеек нескольких документов,желательно не открывая их

LerOK777
Если адреса ячеек известны - без проблем.

Возможно ли такое:

из эксела запускаю файл ворда, он открывается, распечатывается и закрывается?

код в эксел на открытие ворда:

Код:
Sub OpenWordDoc()
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open("c:\rj.doc")
End Sub

nopoxz
Ну, так объедините и все. Примерно так:

Код: Sub Prn()

Dim wdApp As Object, wdDoc As Object

Set wdApp = CreateObject("Word.Application")
Set wdDoc = wdApp.Documents.Open("C:\rj.doc")

wdDoc.PrintOut
wdApp.Quit

Set wdApp = Nothing
Set wdDoc = Nothing

End Sub

продвинулся чуть дальше, но проблема теперь с выбором диапазона. Мне нужно 10 раз расширить его вниз (xlDown), но и в цикле, и 10ью строками, срабатывает только одна команда .Range(Selection, Selection.End(xlDown)).Select, как будто каждый раз сбрасывается в начало.


Код: Sub AktRemake()
Const str1 = "Мы, нижеподписавшиеся, _______________ "
Const str2 = " _______________________, с одной стороны, и ________________ "
Const str3 = " _______________________, с другой стороны, составили настоящий акт."
Dim contr1 As String
Dim contr2 As String
Dim FileList As Variant
Dim wbCurrent As Workbook
Dim i As Integer, j As Integer

On Error GoTo 0
With Application
FileList = .GetOpenFilename("Excel Files (*.xls), *.xls", , "Выберите файлы", , True)
If Not IsArray(FileList) Then End
End With

For i = LBound(FileList) To UBound(FileList)
Set wbCurrent = Workbooks.Open(FileList(i), ReadOnly:=False)
With wbCurrent.Worksheets(1)
.Range("A1").Select
.Range(Selection, Selection.End(xlToRight)).Select
.Range(Selection, Selection.End(xlDown)).Select
End With

' wbCurrent.Save
' wbCurrent.Close
Next
End Sub

oji
1) Что значит "
Цитата:

справа от неё

или
Цитата:

она выше

2) Ищем "от " и дальше что угодно? Т.е. такая строка только раз встречается в Этом столбце?



Цитата:

Мне нужно 10 раз расширить его вниз (xlDown), но и в цикле, и 10ью строками

Тоже не понятно, чего Вы хотите. Какой диапазон "расширять"?
Интерпретационные методы .End(xl...) - зависят от того, как заполнены ячейки.

Код: Sub AktFix()
Const str1 = "Мы, нижеподписавшиеся, _______________ "
Const str2 = " _______________________, с одной стороны, и ________________ "
Const str3 = " _______________________, с другой стороны, составили настоящий акт."
Dim contr1 As String
Dim contr2 As String
Dim FileList As Variant
Dim wbCurrent As Workbook
Dim i As Integer, j As Integer

On Error GoTo 0
With Application
FileList = .GetOpenFilename("Excel Files (*.xls), *.xls", , "Выберите файлы", , True)
If Not IsArray(FileList) Then End
End With

For i = LBound(FileList) To UBound(FileList)
Set wbCurrent = Workbooks.Open(FileList(i), ReadOnly:=False)
With wbCurrent.Worksheets(1)
.Range("A1").Select
.Cells.Find(What:="От ", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False).Activate
contr1 = ActiveCell
Cells.FindNext(After:=ActiveCell).Activate
contr2 = ActiveCell
.Range("A1").Select
.Range("A1").Select
.Cells.Find(What:="Мы, ", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False).Activate

ActiveCell.Value = str1 + contr1 + str2 + contr2 + str3
End With
wbCurrent.Save
wbCurrent.Close
Next

Подскажите пожалуйста, как можно из vba редактировать формулы, созданные в редакторе формул.
Можно ли это вообще и где об этом можно прочитать.
Спасибо

oji
Код цикла обработки я бы написал так:

Код: For i = LBound(FileList) To UBound(FileList)
Set wbCurrent = Workbooks.Open(FileList(i), ReadOnly:=False)
With wbCurrent.Worksheets(1)
Set x = .Cells.Find(What:="От ", LookAt:=xlPart)
Set y = .Cells.Find(What:="Мы, ", LookAt:=xlPart)
[A1] = str1 & Right(x.Value, Len(x.Value) - 3) & str2 + Right(y.Value, Len(x.Value) - 4) & str3
End With
wbCurrent.Save
wbCurrent.Close
Next

SAS888, спасибо большое.

Всё уже сделал, но выявил баг — если вызываю:


Код: wbCurrent.Save
wbCurrent.Close

Здаствуйте.

У меня имеется две таблицы на разных листах с фамилиями сотрудников, причем в 1 таблице (на 1 листе) фамилий значительно больше чем во 2 таблице (находящейся на 2 листе). Мне нужен макрос который будет бывирать фамилии сотрудников из 1 таблице, которых нету во 2 и записывать их в 3 таблицу (находящююся на 3 листе). Возможно ли это както реализовать?

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

Код: Sub Sel()

Dim x As Range, i As Long
Sheets(3).Cells.ClearContents: Sheets(1).Activate
With Sheets(3)
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
Set x = Sheets(2).Columns("A").Find(Cells(i, "A"), LookAt:=xlWhole)
If x Is Nothing Then .Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A") = Cells(i, "A")
Next
.Activate
End With

End Sub

Troitsky, Yuk и The okk.
Больше года назад помогли написать этот код, сильно благодарен им за это, т.к он всё это время работал без перебоев!

Код: strDate = Day(Now()) & "." & Month(Now())
intHour = Hour(Now()) + 1

Set objExcel = CreateObject("Excel.Application")

objExcel.Workbooks.Open "test.xls"
With objExcel.ActiveWorkbook
If .Sheets(1).Name <> strDate Then ' создаем лист если его не существует
.ActiveSheet.Copy .Sheets(1)
.Sheets(1).Name = strDate
' перенос данных с 24:00 на 0:00
.Sheets(1).Range("E3:E25").Value = .Sheets(1).Range("AD3:AD25").Value
.Sheets(1).Range("E27:E31").Value = .Sheets(1).Range("AD27:AD31").Value
' очистка области
.Sheets(1).Range("F3:AD25", "F27:AD31").ClearContents
End If

With objExcel.ActiveWorkbook.Sheets(1)
' в зависимости от часа заполняем нужные области
.Range(.Cells(3, 6 + intHour), .Cells(18, 6 + intHour)).Value _
= .Range("AE3:AE18").Value
.Range(.Cells(22, 6 + intHour), .Cells(25, 6 + intHour)).Value _
= .Range("AE22:AE25").Value
.Range(.Cells(27, 6 + intHour), .Cells(31, 6 + intHour)).Value _
= .Range("AE27:AE31").Value
End With

.Close True
End With

Set objExcel = Nothing

здрасти!
помогите кто может, пожалуйста!
вопрос такой: в UserForm есть Spreadsheet, который содержит список частей
у меня есть код, который находит часть и вносит её количество в столбик,согласно данным которые user внес в InputBox.
мне нужно чтобы курсор перемещался на ту строчку куда было внесено число.
вот мой код:
код[more]strItemCode = _
InputBox( _
"Please insert the item code", _
"Insert code")
If (Len(strItemCode) = 0) Then
Exit Sub
End If

lngCurRowIndex = c_lngDataFirstRowIndex
bolFound = False
Do While Len(GettingKit.Spreadsheet1.Cells(lngCurRowIndex, 1)) > 0
If (strItemCode = GettingKit.Spreadsheet1.Cells(lngCurRowIndex, 1)) Then
bolFound = True
lngRowFound = lngCurRowIndex
End If
lngCurRowIndex = lngCurRowIndex + 1
Loop

strActualQuantity = _
InputBox( _
"Please insert the actual quantity of " & strItemCode, _
"Insert Actual Quantity")

If (Len(strActualQuantity) = 0) Then
Exit Sub
End If
strCurQuantity = GettingKit.Spreadsheet1.ActiveCell(lngRowFound, 3)
If (Len(strCurQuantity) = 0) Then
GettingKit.Spreadsheet1.Cells(lngRowFound, 3) = strActualQuantity
Else
GettingKit.Spreadsheet1.Cells(lngRowFound, 3) = CLng(GettingKit.Spreadsheet1.Cells(lngRowFound, 3)) + CLng(strActualQuantity)[/more]
заранее спасибо

SAS888 Большое тебе спасибо.

У меня есть есче вопрос, если у меня вторая таблица создана при помощи функции
ВПР(Vlookup), можно ли сделать чтобы твой макрос:
Цитата:

Код:Sub Sel()

Dim x As Range, i As Long
Sheets(3).Cells.ClearContents: Sheets(1).Activate
With Sheets(3)
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
Set x = Sheets(2).Columns("A").Find(Cells(i, "A"), LookAt:=xlWhole)
If x Is Nothing Then .Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A") = Cells(i, "A")
Next
.Activate
End With

End Sub

сравнивал данные 1 таблицы с данными со 2 таблице (созданной при помощи функции ВПР(Vlookup))?

CatF
В принципе, данному макросу все равно, каким образом данные появились в ячейках, т.к. он работает именно с значением а не с формулой (св-во ячейки Value).

У меня на листе много данных и большая часть из них находится в хайде. Хотел сделать поиск даных по листу, да так, чтобы данные в хайде тоже искал и если найдёт, строку эту анхайдил.
Искал макросы на поиски и заметил, что не все макросы работают с данными в хайде. Вот код макроса, который работает с хайдом:


Код:
Sub Search()

W = InputBox("Введи число")

Cells.Find(What:=(W), After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Activate
'Rows("51:51").Select
Selection.EntireRow.Hidden = False 'подсветка

nopoxz
Я бы сделал так:

Код: Sub Fnd()

Dim x As Range, Fst As String
Set x = Cells.Find(What:=InputBox("Введи число"), LookAt:=xlPart)
If Not x Is Nothing Then
Fst = x.Address
Do
Rows(x.Row).Hidden = False
Set x = Cells.FindNext(x)
Loop While Fst <> x.Address
Else
MsgBox "Ничего нет"
End If

End Sub

SAS888

Спасибо, всё работает. А можно добавить выделение найденой ячейки?

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

Пример вида 3 таблицы представлен на 3 листе (написанныйй вручную), возможно ли сделать тоже самое только автоматически?
http://ifolder.ru/7340298

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

Код: Sub Fnd()

Dim x As Range, y As Range, Fst As String
Set x = Cells.Find(What:=InputBox("Введи число"), LookAt:=xlPart)
If Not x Is Nothing Then
Set y = x
Fst = x.Address
Do
Rows(x.Row).Hidden = False
Set y = Union(y, x)
Set x = Cells.FindNext(x)
Loop While Fst <> x.Address
y.Select
Else
MsgBox "Ничего нет"
End If

End Sub

Помогите написать процедуру или дайте плз пример, замучался уже.
Есть книга в ней один лист, на листе кнопка. По нажатию этой кнопки мне нужно перебрать все файлы xls которые находятся в этой же папке что и основная книга (и всех подкаталогах). Нужно открыть каждый найденный файл, проверить, есть ли там лист "Продажи", если есть, то нужно добавить лист в основную книгу и скопировать в него данные из найденного файла/листа.
Пока удалось сгенерировать только следующий бред:
Private Sub LoadBook_Click()

Set ab = ActiveWorkbook

Set ex = CreateObject("Excel.Application")
ex.Application.Visible = False
ex.Application.DisplayAlerts = False

Set fs = Application.FileSearch

With fs
.LookIn = ab.Path
.SearchSubFolders = True
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then
For j = 1 To .FoundFiles.Count
If .FoundFiles(j) <> ab.Path & "\" & ab.Name Then
ex.Workbooks.Open Filename:=.FoundFiles(j), ReadOnly:=True
'ТУТ БЫ НАДО ПРОВЕРИТЬ, ЕСТЬ В ОТРЫТМ ФАЙЛЕ НУЖНЫЙ ЛИСТ,
'ЕСЛИ НЕТ, ПРОДОЛЖИТЬ ЦИКЛ, ЕСЛИ ЕСТЬ, ТО ДОБАВИТЬ НОВЫЙ ЛИСТ
'В ОСНОВНУЮ КНИГУ С ИМЕНЕМ, РАВНЫМ ИМЕНИ НАЙДЕННОГО ФАЙЛА К
'К ПРИМЕРУ
ab.Worksheets.Add
ex.Sheets(1).UsedRange.Copy
ab.Sheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
'ТАК КОПИРУЕТСЯ ЛИСТ БЕЗ ФОРМАТИРОВАНИЯ И ТУТ ТУПО В ПЕРВЫЙ
'ЛИСТ ДАННЫЕ КОПИРУЮТСЯ, НО ПО ДРУГОМУ У МЕНЯ НЕ ПОЛУЧАЕТСЯ
'Т.К. КОГДА СОЗДАЮ НОВЫЙ ЛИСТ, ОН ПОЧЕМУ ТО ПЕРВЫМ СТАНОВИТЬСЯ
'А НЕ ПОСЛЕДНИМ
ex.Workbooks.Close
End If
Next
Else
MsgBox ("Файлы не найдены")
End If
End With

Set fs = Nothing
'Set ex = Nothihg

End Sub

VanoZZZ
Может Вам, конечно, все равно, но метод FileSearch в Excel 2007 отключен. Для того, чтобы макрос выполнялся при любом установленном Office, Вашу задачу я решил бы так:

Код: Sub Main()

Dim myPath As String, myName As String, Wb As Workbook, Ws As Worksheet
Application.ScreenUpdating = False
myPath = ThisWorkbook.Path & Application.PathSeparator
myName = Dir(myPath & "*.XLS", vbNormal + vbReadOnly)
Do While myName <> ""
If myName <> ThisWorkbook.Name Then
Set Wb = Workbooks.Open(Filename:=myPath & myName)
On Error Resume Next
Set Ws = Sheets("Продажи")
If Err <> 0 Then GoTo Metka
On Error GoTo 0
Sheets("Продажи").Copy After:=Workbooks(ThisWorkbook.Name).Sheets(Sheets.Count)
ActiveSheet.Name = myName & "_Продажи"
Metka: Wb.Close
End If
myName = Dir
Loop
Sheets(1).Activate ' Это не обязательно

End Sub

SAS888 огромное тебе спасибо.

А можно к твоему макросу:

Sub CreateTotal1C()

Dim Ncol As Integer, x As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Sheets("&#210;&#224;&#225;&#235;&#232;&#246;&#224; 1&#209;").Delete
On Error GoTo 0
Worksheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "&#210;&#224;&#225;&#235;&#232;&#246;&#224; 1&#209;"
Sheets(1).Columns("I").Copy [A1]: Sheets(1).Columns("H").Copy [B1]
Rows("1:3").Delete
Columns("A:D").ColumnWidth = 17
Ncol = 1: Call SumDel(Ncol)
Ncol = 3: Call SumDel(Ncol)

End Sub


Добавить условие: если форма уже существует то удалять или создовать новую не надо.
Или просто сделать так чтоб макрос не создовал и не удалял формы, а работал уже в существующей заданной форме?

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