Autofilter with .Sheets(Array) - arrays

Question

This is my first post on Stack Overflow.
I have an Excel file that contains multiple sheets with data. Sheet "Emailer" contains buttons to hit the macro. The macro is working fine, while running it copies the defined sheets into new workbook and create an outlook email with attachment.
All is working fine, I would need a filter on a specific column to filter the data before copy and past into new workbook. Currently, all the data with no filter is copying. The specific column (M) is available in all 4 sheets that I want to filter (basis the value available under it) and copy paste.
Below is my code i am struggling with to achieve what i want.
Request to help and applgoies if i havent follow any rule of posting the question.
Thansk in advance.
Sub MIS_Mail()
Dim rng As Range
Dim rng2 As Range
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim StrSignature As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim sh As Worksheet
Dim TheActiveWindow As Window
Dim TempWindow As Window
Set ws = Sheets("Emailer")
Set ws2 = Sheets("GROW MONEY")
Set rng = Nothing
'Set rng2 = Nothing
On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = ws2.Range("A2:M34").SpecialCells(xlCellTypeVisible)
'Set rng2 = ws2.Range("B18:I33").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the ActiveSheet to a new workbook
With Sourcewb
Set TheActiveWindow = ActiveWindow
Set TempWindow = .NewWindow
.Sheets(Array("GROW MONEY", "Tranche wise details", "All products Deal limit status", "Delinquency")).Copy ' here i want to filter the data in all three sheets before copy
End With
'Close temporary Window
TempWindow.Close
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
' 'Change all cells in the worksheet to values if you want
For Each sh In Destwb.Worksheets
sh.Select
With sh.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
Destwb.Worksheets(1).Select
Next sh
Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = Sourcewb.Name
strBody = "<font face=""Calibri"" size=""2"" color=""#1F497D"">" & "Dear All," & "<br> <br>" & _
"Please find attached MIS Report as on " & Format(ws2.Range("B1").Value, "DD-MMM-YY") & "." & "<br><br>" & "</font>"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
On Error Resume Next
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = ws.Range("C5").Value
.CC = ws.Range("D5").Value
.BCC = ""
.Subject = ws.Range("E5").Value
.HTMLBody = strBody & RangetoHTML(rng) '& RangetoHTML2(rng2) & vbNewLine '& StrSignature '& Signature
.Attachments.Add Destwb.FullName
.Display 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Function RangetoHTML2(rng2 As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng2.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML2 = ts.readall
ts.Close
RangetoHTML2 = Replace(RangetoHTML2, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
I have tried to do something with Autofilter with array() but not luckm here is the edited code:
Sub MIS_Mail()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
Dim rng As Range
Dim rng2 As Range
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim StrSignature As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim sh As Worksheet
Dim TheActiveWindow As Window
Dim TempWindow As Window
Dim CatSites As String
Set ws = Sheets("Emailer")
Set ws2 = Sheets("GROW MONEY")
Set rng = Nothing
'Set rng2 = Nothing
On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = ws2.Range("A2:M50").SpecialCells(xlCellTypeVisible)
'Set rng2 = ws2.Range("B18:I33").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the ActiveSheet to a new workbook
With Sourcewb
Set TheActiveWindow = ActiveWindow
Set TempWindow = .NewWindow
CatSites = "GROW"
.Sheets(Array("GROW MONEY", "Tranche wise details", "All products Deal limit status", "Delinquency")).AutoFilter
.Sheets(Array("GROW MONEY", "Tranche wise details", "All products Deal limit status", "Delinquency")).AutoFilter field:=13, Criteria1:=CatSites
.Sheets(Array("GROW MONEY", "Tranche wise details", "All products Deal limit status", "Delinquency")).SpecialCells(xlCellTypeVisible).Copy
End With
'Close temporary Window
TempWindow.Close
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
' 'Change all cells in the worksheet to values if you want
For Each sh In Destwb.Worksheets
sh.Select
With sh.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
Destwb.Worksheets(1).Select
Next sh
Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = Sourcewb.Name
strBody = "<font face=""Calibri"" size=""2"" color=""#1F497D"">" & "Dear All," & "<br> <br>" & _
"Please find attached MIS Report as on " & Format(ws2.Range("B1").Value, "DD-MMM-YY") & "." & "<br><br>" & "</font>"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
On Error Resume Next
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = ws.Range("C2").Value
.CC = ws.Range("D2").Value
.BCC = ""
.Subject = ws.Range("E2").Value
.HTMLBody = strBody & RangetoHTML(rng) '& RangetoHTML2(rng2) & vbNewLine '& StrSignature '& Signature
.Attachments.Add Destwb.FullName
.Display 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

Answer 1

You could work with similar code as later in your Sub (usually not needed to post your entire sub if it's this long, just the bit you're struggling with)
Sub MIS_Mail()
Dim rng As Range, rng2 As Range
Dim ws As Worksheet, ws2 As Worksheet, sh As Worksheet, nsh As Worksheet
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim StrSignature As String, FileExtStr As String, TempFilePath As String, TempFileName As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook, Destwb As Workbook
Dim TheActiveWindow As Window, TempWindow As Window
Dim shArray As Variant, arrSheet As Variant
Set ws = Sheets("Emailer")
Set ws2 = Sheets("GROW MONEY")
Set rng = Nothing
'Set rng2 = Nothing
On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = ws2.Range("A2:M34").SpecialCells(xlCellTypeVisible)
'Set rng2 = ws2.Range("B18:I33").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set Sourcewb = ActiveWorkbook 'easier to declare these to copy the sheets while going through the for each loop after filtering them
Set Destwb = Workbooks.Add
Sourcewb.Activate
shArray = Array(Sheets("Tranche wise details"), Sheets("All products Deal limit status"), Sheets("Delinquency"), Sheets("GROW MONEY"))
For Each arrSheet In shArray 'Filter before you do the copying
Set sh = arrSheet
Set nsh = Destwb.Sheets.Add
nsh.Name = sh.Name
If sh.AutoFilterMode Then 'autofilter is 'on'
On Error Resume Next
sh.ShowAllData 'clearing existing filters
sh.Columns("M:M").Copy 'getting rid of the formulas first
sh.Columns("M:M").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
sh.Range("M1").AutoFilter Field:=13, Criteria1:="UGRO"
On Error GoTo 0
Else
sh.Columns("A:A").Copy
sh.Columns("A:A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
sh.Range("M1").AutoFilter Field:=13, Criteria1:="UGRO" 'still not getting any errors here on the testfile
End If
sh.UsedRange.Copy nsh.Range("A1")
nsh.UsedRange.Copy
nsh.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
Next arrSheet
Application.DisplayAlerts = False
Destwb.Sheets(Destwb.Sheets.Count).Delete 'delete the sheet the workbook started with (depending on the language, these differ)
Application.DisplayAlerts = True
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
Application.CutCopyMode = False
Destwb.Activate 'Destwb is ready to be mailed"
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = Sourcewb.Name
strBody = "<font face=""Calibri"" size=""2"" color=""#1F497D"">" & "Dear All," & "<br> <br>" & _
"Please find attached MIS Report as on " & Format(ws2.Range("B1").Value, "DD-MMM-YY") & "." & "<br><br>" & "</font>"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
On Error Resume Next
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = ws.Range("C5").Value
.CC = ws.Range("D5").Value
.BCC = ""
.Subject = ws.Range("E5").Value
.HTMLBody = strBody & RangetoHTML(rng) '& RangetoHTML2(rng2) & vbNewLine '& StrSignature '& Signature
.Attachments.Add Destwb.FullName
.Display 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Function RangetoHTML2(rng2 As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng2.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML2 = ts.readall
ts.Close
RangetoHTML2 = Replace(RangetoHTML2, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
My Test Sub: ONLY USED ON YOUR TESTFILE, THIS IS NOT THE FULL SUB
Sub TESTMIS_Mail()
Dim rng As Range, rng2 As Range
Dim ws As Worksheet, ws2 As Worksheet, sh As Worksheet, nsh As Worksheet
Dim StrSignature As String, FileExtStr As String, TempFilePath As String, TempFileName As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook, Destwb As Workbook
Dim TheActiveWindow As Window, TempWindow As Window
Dim shArray As Variant, arrSheet As Variant
Set Sourcewb = ActiveWorkbook
Set Destwb = Workbooks.Add
Sourcewb.Activate
shArray = Array(Sheets("Tranche wise details"), Sheets("All products Deal limit status"), Sheets("Delinquency"), Sheets("GROW MONEY"))
For Each arrSheet In shArray 'Filter before you do the copying
Set sh = arrSheet
Set nsh = Destwb.Sheets.Add
nsh.Name = sh.Name
If sh.AutoFilterMode Then 'autofilter is 'on'
On Error Resume Next
sh.ShowAllData 'clearing existing filters
sh.Range("M1").AutoFilter Field:=13, Criteria1:="UGRO"
On Error GoTo 0
Else
sh.Range("M1").AutoFilter Field:=13, Criteria1:="UGRO"
End If
sh.UsedRange.Copy nsh.Range("A1")
nsh.UsedRange.Copy
nsh.Range("A1").PasteSpecial xlPasteValues
Next arrSheet
Application.DisplayAlerts = False
Destwb.Sheets(Destwb.Sheets.Count).Delete
Application.DisplayAlerts = True
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
Application.CutCopyMode = False
Destwb.Activate
End Sub
Hope this is what you were looking for.