Создание резервных копий ценных файлов

Этот макрос сохраняет текущую книгу в папку C:\TEMP, добавляя к имени книги текущее время и дату.

Sub Backup_Active_Workbook()

Dim x As String

strPath = "c:\TEMP"

On Error Resume Next

x = GetAttr(strPath) And 0

If Err = 0 Then ' если путь существует - сохраняем копию книги

strDate = Format(Now, "dd/mm/yy hh-mm")

FileNameXls = strPath & "\" & Left(ActiveWorkbook.Name, _

Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".xls"

ActiveWorkbook.SaveCopyAs Filename:=FileNameXls

Else 'если путь не существует - выводим сообщение

MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical

End If

End Sub

При желании можно заменить первую строку на:

Private Sub Workbook_BeforeClose(Cancel As Boolean)

и поместить этот макрос не в Module1 как обычно, а в модуль ЭтаКнига (ThisWorkbook) - тогда автоматическое сохранение резервной копии будет происходить каждый раз перед закрытием файла.

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

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