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

Количество открытий файла (вариант 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