Готовые макросы в vba excel, Миронов Глава Макросы 9

• Название: Готовые макросы в vba excel, Миронов Глава Макросы 9
• Дата: 06.02.2018
• Размер: 1.35 Mb.
• Имя файла: 33980_7d1642e70814394f108d07a8a2edd23e.doc
• Тип: Документы; #35930
• страница: 7 из 47

Подсчет количества открытий файла

Количество открытий файла (вариант 1)

Sub Auto_Open()

Worksheets(1).Cells(1) = Worksheets(1).Cells(1) + 1

End Sub

Количество открытий файла (вариант 2)

Sub Auto_Open()

Worksheets(1).Cells(1, 1) = Worksheets(1).Cells(1, 1) + 1

End Sub

Количество открытий файла (вариант 3)

Sub Auto_Open()

Worksheets(1).Range("A1") = Worksheets(1).Range("A1") + 1

End Sub

Вывод пути к файлу в активную ячейку

Sub ExcelSearch()

Dim fname As String
Dim result As Integer
With Application.FileDialog(1) ' ?????? : With Application.FileDialog(msoFileDialogOpen) '
.Title = "Select Excel file"

.InitialFileName = "C:\" 'default path'
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Pack files", "*.xls", 1
result = .Show

If result = 0 Then Exit Sub
fname = Trim(.SelectedItems.Item(1))
End With

'On Error Resume Next

ActiveCell = fname


End Sub

Копирование содержимого файла RTF в эксель

Sub OpenRtfAndPasteToSheets()

Dim wd As Object

Dim ns As Worksheet

On Error Resume Next

'запустим Ворд

Set wd = GetObject("", "Word.Application")

If Err.Number <> 0 Then

Err.Clear

Set wd = CreateObject("Word.Application")

If Err.Number <> 0 Then Exit Sub

End If

On Error GoTo BAD

Do

'получим имя очередного файла

f = Application.GetOpenFilename("Файлы RTF, *.rtf,Все файлы, *.*")

If TypeName(f) = "Boolean" Then Exit Do 'если Отмена - выход

'откроем выбранный очередной файл

Set wdd = wd.Documents.Open(f)

' wd.Visible = True

'скопируем содержимое документа

t = wdd.Content.Copy

'создадим лист для этого документа

Set ns = ActiveWorkbook.Worksheets.Add

'вставим скопированное в новый лист

ns.Paste Destination:=ns.Cells(1, 1)

'немного выравним вид

ns.Cells.WrapText = False

ns.Columns.AutoFit

ns.Rows.AutoFit

wdd.Close

Loop

wd.Quit

Set wd = Nothing

Exit Sub

BAD:

MsgBox Err.Description

On Error Resume Next

wd.Quit

Set wd = Nothing

End

End Sub

Копирование данных из закрытой книги

ActiveCell.FormulaR1C1 = "='D:\contacts\zakaz\[zakaz.xls]Лист1'!R1C1"

Извлечение данных из закрытого файла

Sub GetDataFromFile()

Range("A1").Formula = "='C:\[Example.xls]Лист1'!A1"

End Sub

Поиск слова в файлах

Option Explicit

Sub Поиск_во_всех_файлах()

Dim iShtName$, iPath$, iFileName$, firstAddress$

Dim iSheet As Worksheet, iFoundSht As Worksheet

Dim iTempWB As Workbook, iBazaWB As Workbook

Dim TextToFind As Variant, iFoundRng As Range

Dim FD As FileDialog, iLastRow&

Dim FoundAny As Boolean

TextToFind = Application.InputBox("Введите текст для поиска:", "Поиск")

If TextToFind = "" Or TextToFind = False Then Exit Sub

TextToFind = Trim(TextToFind)

Set FD = Application.FileDialog(msoFileDialogFilePicker)

With FD

.AllowMultiSelect = False

.Title = "Укажите любой файл в папке"

.ButtonName = "Выбрать папку"

If .Show = False Then Exit Sub Else iPath = Mid(.SelectedItems(1), 1, InStrRev(.SelectedItems(1), "\"))

End With

Set FD = Nothing

Workbooks.Add

Sheets.Add.Name = "Поиск"

Set iFoundSht = ActiveSheet

iFoundSht.Cells(1, 1) = "Ищем: " & TextToFind

iFoundSht.Cells(1, 1).Font.Bold = True

With Application

.ScreenUpdating = False

.Calculation = xlManual

.StatusBar = "Идёт поиск..."

.ShowWindowsInTaskbar = False

iFileName = Dir(iPath & "*.xls")

Do While iFileName$ <> ""

Set iTempWB = Workbooks.Open(Filename:=iPath & iFileName, UpdateLinks:=False, ReadOnly:=True)

For Each iSheet In iTempWB.Sheets

If iSheet.FilterMode = True Then iSheet.ShowAllData

Set iFoundRng = iSheet.Cells.Find(What:=TextToFind, LookIn:=xlFormulas, LookAt:=xlPart)

If Not iFoundRng Is Nothing Then

FoundAny = True

firstAddress = iFoundRng.Address

Do

With iFoundSht

iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

If iLastRow = 1 Then iLastRow = 2

If iShtName <> iSheet.Name Then 'если новый файл

With .Cells(iLastRow + 2, 1)

.Value = "Файл: " & iTempWB.Name & ", Лист: " & iSheet.Name

.Font.Bold = True

End With

End If

iFoundRng.EntireRow.Copy Destination:=.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1) 'копируем всю строку

iShtName = iSheet.Name

End With

Set iFoundRng = iSheet.Cells.FindNext(iFoundRng)

Loop While iFoundRng.Address <> firstAddress

Else

End If

Next

iTempWB.Close SaveChanges:=False

iFileName = Dir

Loop

.StatusBar = False

.ShowWindowsInTaskbar = True

.EnableEvents = True

.Calculation = xlCalculationAutomatic

.ScreenUpdating = True

End With

If FoundAny = False Then

MsgBox "Текст '" & TextToFind & "' ни в одном из файлов в папке:" & Chr(10) & iPath & Chr(10) & " не был найден!", 48, "Отчёт"

iFoundSht.Parent.Close SaveChanges:=False

Exit Sub

End If

MsgBox "Поиск " & TextToFind & " завершён!", 64, "Поиск"

End Sub