Sub Proc()    Range("A" & Rows.Count).End(xlUp).Offset(1).Select
    Application.OnTime Now + TimeValue("00:00:05"), "Proc"
End Sub
Private Sub Workbook_Open()
    Proc
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("H:H")) Is Nothing Then
Call Proc
End If
End Sub

Sub Proc()
   Range("A" & Rows.Count).End(xlUp).Offset(1).Select
End Sub

Sub Proc()
   Range("A" & Rows.Count).End(xlUp).Offset(1).Select
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
sv = Sheets("Лист1").Cells(1, 1)
' Имя листа с ячейкой А1
If Len(sv) = 0 Then Exit Sub
sv = sv & ".xls"
S = ThisWorkbook.Name
If S <> sv Then
  s1 = ThisWorkbook.FullName
  s2 = ThisWorkbook.Path
  s2 = s2 & "/" & sv
  ThisWorkbook.SaveAs Filename:=s2
  Kill s1
End If
End Sub

Sub txt()
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
Set ts = FSO.CreateTextFile(BaseFolder$ & "Текст.txt", True)
ts.Close
With CreateObject("Scripting.FileSystemObject").OpenTextFile(BaseFolder$ & "Текст.txt", 8)
.writeline Join(Application.Transpose([a1:a25].Value), vbCrLf)
.Close
End With
CreateObject("wscript.shell").Run "explorer.exe /e, """ & BaseFolder$ & "Текст.txt" & """"
End Sub

Private Sub Workbook_Open()
sv = Sheets("Лист1").Cells(1, 1)
' Имя листа с ячейкой А1
If Len(sv) = 0 Then Exit Sub
sv = sv & ".xls"
s = ThisWorkbook.Name
If s <> sv Then
s1 = ThisWorkbook.FullName
s2 = ThisWorkbook.Path
s2 = s2 & "/" & sv
ThisWorkbook.SaveAs Filename:=s2
Kill s1
End If
End Sub

Sub Макрос1()
Dim iFileName As String 'имя файла
Dim iPath As String 'путь для сохранения
    iFileName = Range("E5")
    'если ячейка E5 пуста
    If iFileName = "" Then
        MsgBox "Имя файла не указано!", vbExclamation, "Ошибка"
        Exit Sub
    End If
    iPath = "C:\"
    ActiveWorkbook.SaveAs Filename:=iPath & iFileName, FileFormat:=xlExcel9795
End Sub

Sub CommandButton1_Click()
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject"  ;)  
' создаём главную папку
BaseFolder$ = ThisWorkbook.Path & "\MIDI\": MkDir BaseFolder$
MkDir BaseFolder$
' создаём файл в кодировке Unicode
Set ts = FSO.CreateTextFile(BaseFolder$ & "sample.txt", True)
ts.Close
With CreateObject("Scripting.FileSystemObject"  ;)  .OpenTextFile(BaseFolder$ & "sample.txt",  8)  
.writeline Join(Application.Transpose([a1:a5].Value), vbCrLf)
.Close
End With
' Set ts = Nothing: Set FSO = Nothing
' MsgBox "Файлы созданы, и помещены в папку" & vbNewLine & BaseFolder$, vbInformation, "Готово"
' открываем папку с файлом
CreateObject("wscript.shell"  ;)  .Run "explorer.exe /e, """ & BaseFolder$ & "sample.txt" & """"
End Sub