I got a macro that loops through a directory and performs a calculation.
When i run my macro I have to manually check the compatibility,
Is there a way I can skip the whole check compatibility? it kind of defeats the purpose of this automation.
Sub final()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'This Loops trough all files, does calc, then closes them. But right now I have to check compatibility for each file.
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
Dim xrng As Range, lrw As Long, lrng As Range, i As Long
Dim LstCo As Long, ws As Worksheet
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
For Each ws In ActiveWorkbook.Worksheets
With ws
If Not Application.WorksheetFunction.CountA(.Cells) = 0 Then
LstCo = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
For i = 1 To LstCo
With .Columns(i)
.TextToColumns Destination:=.Cells(1, 1), DataType:=xlDelimited, TrailingMinusNumbers:=True
End With
Next
lrw = .Columns("A:Y").Find("*", , xlValues, , xlRows, xlPrevious).Row
If lrw = 1 Then lrw = 2
Set lrng = .Range("A" & lrw + 2)
With .Range("A2:A" & lrw)
lrng.Formula = "=COUNTA(" & .Address(0, 0) & ")/ROWS(" & .Address(0, 0) & ")"
End With
Set xrng = .Range(lrng, .Cells(lrng.Row, LstCo))
lrng.AutoFill xrng, Type:=xlFillDefault
xrng.Style = "Percent"
End If
End With
Next
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
Application.CalculateFull
End With
'Save and Close Workbook
wb.Close SaveChanges:=True
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Add the line wb.CheckCompatibility = False before saving the file - documentation here
Related
I have a macro which loops through excel files in a network drive path and performs few operations on the pivots and then tries to save the file in the same network path.
It works fine for the first 5 - 10 files and then it randomly stops saving the files.
The progress bar in the save box does not go any further.
Unable to save image
I have included the VBA code below
Sub CLEAR_ADI_PIVOT_DT_SRC()
Dim myPath As String
Dim myExtension As String
Dim myFile As String
Dim wb As Workbook
Dim ws As Worksheet
Dim FilePath As String
Dim PriorQuarter As String
Dim PrevQtrSheet As String
Dim filestr1 As String
Dim PrevQuarter As String
PrevQtrSheet = "Rebates Template " & Range("B2").Value
PrevQuarter = Range("B2").Value
PriorQuarter = Range("A2").Value
myPath = Range("I2").Value & "ADI\"
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If
On Error GoTo ErrHandler
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Target File Extension (must include wildcard "*")
myExtension = "*.xl*"
'Target Path with Ending Extension
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Application.DisplayAlerts = False
Debug.Print myPath & myFile
Set wb = Workbooks.Open(filename:=myPath & myFile, UpdateLinks:=False)
wb.Worksheets("ADI").Visible = True
wb.Worksheets("ADI").Activate
Cells.Find(What:="totals:", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(-1, 0).Select
Dim AdiClearRange As Range
Set AdiClearRange = Range("AE" & ActiveCell.Row, "C14")
AdiClearRange.Select
Selection.ClearContents
Range("B15").Select
'Insert rows in ADI sheet
Dim x As Long
For x = 1 To 500
Range("B19:AE19").Select
Selection.Copy
Selection.Insert Shift:=xlDown
Range("B14").Select
Application.CutCopyMode = False
Next x
'Delete prior quarter template sheet
For Each Sheet In wb.Worksheets
If Sheet.Name = "Rebates Template " & PriorQuarter Then
Sheet.Delete
End If
Next Sheet
'change data source of previous quarter pivots
'Get range of the previous template
wb.Worksheets(PrevQtrSheet).Activate
Range("AH5").Select
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilter.ShowAllData
ActiveSheet.Range("$A$5:$KD$683").AutoFilter Field:=34, Criteria1:="<>"
'ActiveSheet.Range("$A$5:$KD$683").AutoFilter Field:=34, Criteria1:="<>0"
Range("AH5").Select
Selection.End(xlDown).Select
'Change range of pivot 1 and pivot 7 and apply previous quarter filter in pivots
Dim rng As Range
Dim SourceAddress As String
Set rng = Range("A5", "AH" & ActiveCell.Row)
SourceAddress = "'" & PrevQtrSheet & "'" & "!" & "$A$5:" & ActiveCell.Address(RowAbsolute:=True, ColumnAbsolute:=True)
Debug.Print SourceAddress
Sheets("Check").Select
Dim myPivotField As PivotField
Dim filterValue As String
ActiveSheet.PivotTables("PivotTable3").ChangePivotCache wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=SourceAddress)
ActiveSheet.PivotTables("PivotTable3").RefreshTable
ActiveSheet.Range("P1").Value = PrevQuarter
wb.Close SaveChanges:=True
'Get next file name
myFile = Dir
Loop
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
ErrHandler:
'MsgBox Err.Description, vbExclamation
'Resume ResetSettings
End Sub
I am running into an issue with the code below. The "Cash Flow" sheet will not change the height to fit onto one page. When I use a breakpoint it works but that line seems to be skip when running the macro.I have tried using Application.Wait but that did not work. Any thoughts on how I can fix it? Thanks in advance!
Section of the code that is not working:
Sheets("Cash Flow").Select
With ActiveSheet.PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
Full Code:
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
`enter code here` If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Sets Page Height ad Width
Dim myArray() As Variant
Dim i As Integer
For i = 1 To Sheets.Count
ReDim Preserve myArray(i - 1)
myArray(i - 1) = i
Next i
Sheets(myArray).Select
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 0
End With
Sheets("Cash Flow").Select
With ActiveSheet.PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
strName = CreateObject("Scripting.FileSystemObject").GetBaseName(ActiveWorkbook.Name)
'create default name for savng file
strFile = strName & ".pdf"
strPathFile = strPath & strFile
'export to PDF in current folder
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=strPathFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Setup - I have a macro that's in an excel file, when I click a button it will 1) go to a folder 2) Run the code for all xlsx files.
Problem - I tested parts of the code and it works but when I do the entire thing it doesnt. Debugging highlights a section which I will show shortly.
Sub CommandButton1_Click()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xlsx*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Change First Worksheet's Background Fill Blue
'This code below gave us the first column but if clicked twice we have a problem'
ActiveSheet.Columns("A").Insert Shift:=xlToRight
ActiveSheet.Columns("A").Insert Shift:=xlToLeft
'Added the title Source 2 to A1'
Range("A1").Value = "XX"
Range("B1").Value = "XX"
'Perform the Find/Replace All'
Columns("I").Replace What:="XX", _
Replacement:="XX", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
'Solution to the columns A and B
**Dim arrData As Variant, LastRow As Long, i As Long, ws As Worksheet
Set ws = ThisWorkbook.Sheets("newreport") 'change the name of the sheet to the one you are doing the code**
With ws
LastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
arrData = .Range("A2", .Cells(LastRow, "C")).Value
For i = 1 To UBound(arrData)
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
There's one line of code that is the problem,
**Dim arrData As Variant, LastRow As Long, i As Long, ws As Worksheet
Set ws = ThisWorkbook.Sheets("newreport")
How can I get through this problem?
I think I need to rewrite this code
Dim arrData As Variant, LastRow As Long, i As Long, ws As Worksheet
Set ws = ThisWorkbook.Sheets("report1538393886588") 'change the name of the sheet to the one you are doing the code
With ws
LastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
arrData = .Range("A2", .Cells(LastRow, "C")).Value
For i = 1 To UBound(arrData)
If arrData(i, 3) Like "XXX*" Then
arrData(i, 1) = "XX XXX"
Else
arrData(i, 1) = "XXX XXX"
End If
If arrData(i, 3) Like "CSI*" Or arrData(i, 3) = vbNullString Then
arrData(i, 2) = vbNullString
Else
arrData(i, 2) = Right(arrData(i, 3), Len(arrData(i, 3)) - 12)
End If
Next i
.Range("A2", .Cells(LastRow, "C")).Value = arrData
End With
For Each cell In Range("B2", Range("B605536").End(xlUp))
If Not IsEmpty(cell) Then
cell.Value = Right(cell, Len(cell) - 2)
End If
Next cell
So the code is two parts.
Part A) Open a the folder directory and when you click OK. It Runs the Code of Part B. Then saves the file, and finally outputs a msg box.
Part B) It runs the code on the file.
Hypothesis: That 2 lines of code is the reason why it does not work. I believe the first is initiating the code to run and second is this Set ws = ThisWorkbook.Sheets("report123")
Here is the entire code
Public Sub CommandButton1_Click()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
My Code for the file starts here
ActiveSheet.Columns("A").Insert Shift:=xlToRight
ActiveSheet.Columns("A").Insert Shift:=xlToLeft
Range("A1").Value = "Source 2"
Range("B1").Value = "BU ID"
Columns("I").Replace What:="eas", _
Replacement:="reC", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
Dim arrData As Variant, LastRow As Long, i As Long, ws As Worksheet
Set ws = ThisWorkbook.Sheets("report123")
With ws
LastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
arrData = .Range("A2", .Cells(LastRow, "C")).Value
For i = 1 To UBound(arrData)
If arrData(i, 3) Like "Bus*" Then
arrData(i, 1) = "BU CRM"
Else
arrData(i, 1) = "CSI ACE"
End If
If arrData(i, 3) Like "CSI*" Or arrData(i, 3) = vbNullString Then
arrData(i, 2) = vbNullString
Else
arrData(i, 2) = Right(arrData(i, 3), Len(arrData(i, 3)) - 12)
End If
Next i
.Range("A2", .Cells(LastRow, "C")).Value = arrData
End With
My Code for the file ends here
wb.Close SaveChanges:=True
DoEvents
myFile = Dir
Loop
MsgBox "Task Complete!"
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I am still new to VBA, I am just curious if anyone has any recommendations for improving or simplifying this code. The program works fine the way it is, however it has to sort through anywhere from 10 to 30 files and marge them all. It can take a long time depending on the file size. The Excel files range from a few hundred lines to 800,000 each. Thanks for your help!
Option Compare Text
Sub MergeAllFiles()
Dim wb As Workbook
Dim myPath As String, MyFile As String, myExtension As String, Col1 As
String, MyFolder As String, Title As String
Dim i As Integer, j As Integer, WS_Count As Integer, k As Integer
Dim FldrPicker As FileDialog
Dim Mynote As String, Answer As String
Mynote = "Does each file have the same number of export fields?"
Answer = MsgBox(Mynote, vbQuestion + vbYesNo, "Confirmation Needed")
If Answer = vbNo Then
MsgBox "Cancelled"
GoTo ResetSettings
End If
j = 1
i = 1
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select A Target Folder"
.AllowMultiSelect = False
.Show
MyFolder = .SelectedItems(1)
Err.Clear
End With
Set NewBook = Workbooks.Add
With NewBook
.Title = "MasterList"
ActiveWorkbook.SaveAs Filename:="Mastersheet.xlsx"
End With
'Loop through each Excel file in folder
MyFile = Dir(MyFolder & "\", vbReadOnly)
If MyFile = "Batch.xlsx" Then GoTo NextLoop
Do While MyFile <> ""
DoEvents
Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False
Title = ActiveWorkbook.Name
ActiveWorkbook.Sheets(i).Select
With ActiveWorkbook.Sheets(i)
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode)
Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
End With
k = 1
l = 1
If j = 1 Then
k = 0
l = 0
End If
With Range("A1:AB1000000")
Set rFind = .Find(What:="Total Rate (Linehaul + Acc)",
LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
ActiveSheet.Range("A1:ABC1000000").AutoFilter
Field:=rFind.Column, Criteria1:="="
ActiveSheet.Range("A1:ABC1000000").Offset(1,
0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
ActiveSheet.AutoFilterMode = False
End With
ActiveSheet.UsedRange.Offset(l).Copy
Workbooks("Mastersheet.xlsx").Activate
Range("A" & Rows.Count).End(xlUp).Offset(k).Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders,
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(Title).Activate
Application.CutCopyMode = False
Workbooks(MyFile).Close SaveChanges:=True
j = j + 1
If j = 50 Then Exit Do
NextLoop:
MyFile = Dir
Loop
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Not sure if my code does exactly what yours does (had no sample data/input to check the output against), but maybe something like this:
Option Explicit
Private Sub MergeAllFiles()
If MsgBox("Does each file have the same number of export fields?", vbQuestion + vbYesNo, "Confirmation Needed") = vbNo Then
MsgBox "Files do not have same number of export fields. Code will stop running now."
Exit Sub
End If
'Retrieve Target Folder Path From User
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select A Target Folder"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Folder selection cancelled. Code will stop running now."
Exit Sub
End If
Dim folderPath As String
folderPath = .SelectedItems(1)
If VBA.Strings.StrComp(VBA.Strings.Right$(folderPath, 1), "\", vbBinaryCompare) <> 0 Then
folderPath = folderPath & "\"
End If
End With
Dim masterWorksheet As Worksheet
With Workbooks.Add
.SaveAs Filename:=ThisWorkbook.Path & "\Mastersheet.xlsx"
Set masterWorksheet = .Worksheets(1)
End With
' If you're only interested in .xlsx files, then maybe specify the file extension upfront
' when using dir(). This ensures you only loop through files with the given file extension.
' But if you do want multiple file extensions, you could remove extension from the dir()
' and just check file extension inside the loop.
Dim Filename As String
Filename = VBA.FileSystem.Dir$(folderPath & "*.xlsx", vbReadOnly)
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim workbookToCopyFrom As Workbook
Dim fileCount As Long
Dim cellFound As Range
Dim blankRowsToDelete As Range
Dim lastRow As Long
Do While Len(Filename) <> 0
If VBA.Strings.StrComp(Filename, "Batch.xlsx", vbBinaryCompare) <> 0 Then
fileCount = fileCount + 1
Set workbookToCopyFrom = Application.Workbooks.Open(Filename:=folderPath & Filename, UpdateLinks:=False)
' Did you want to copy-paste from all worksheets
' or just the worksheet at the first index?
With workbookToCopyFrom.Worksheets(1)
If .AutoFilterMode Then .AutoFilter.ShowAllData
With .Range("A1:AB1000000")
' Presume this check is done because you want to include headers the first time,
' but exclude headers for any subsequent files.
If fileCount = 1 Then
.Rows(1).Copy masterWorksheet.Rows(1)
End If
Set cellFound = .Find(What:="Total Rate (Linehaul + Acc)", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
' It's worth checking if the previous line found anything
' If it didn't, you will get an error below when accessing the 'column' property
.AutoFilter Field:=cellFound.Column, Criteria1:="="
Set blankRowsToDelete = Application.Intersect(.EntireRow, .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow)
If Not (blankRowsToDelete Is Nothing) Then
blankRowsToDelete.Delete
End If
.Parent.AutoFilterMode = False
End With
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
.Range("A2:AB" & lastRow).Copy
masterWorksheet.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
workbookToCopyFrom.Close SaveChanges:=False
End If
End With
If fileCount = 50 Then Exit Do
End If
DoEvents
Filename = Dir$()
Loop
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub