Object doesn't support property or method - array of sheets - arrays

I have a master file having different account details. I am trying to make a code that will send a copy of the workbook after deleting unnecessary account details and mail it. It is working fine for one sheet but when I am using array for multiple sheets it is giving me object doesn't support method in this line of code ".DisplayPageBreaks = False".
Here is my code:
Sub Mail_Sheets_Array()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
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 OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim TheActiveWindow As Window
Dim TempWindow As Window
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the sheets to a new workbook
'We add a temporary Window to avoid the Copy problem
'if there is a List or Table in one of the sheets and
'if the sheets are grouped
With Sourcewb
Set TheActiveWindow = ActiveWindow
Set TempWindow = .NewWindow
.Sheets(Array("REC_INT", "REC_EXT")).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 worksheets 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
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim prow As Long
Dim r As Long
Dim x As Long
Dim y As Long
Dim CalcMode As Long
Dim ViewMode As Long
r = 0
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'We use the ActiveSheet but you can replace this with
With Destwb.Sheets(Array("REC_INT", "REC_EXT"))
' With ActiveSheet
'We select the sheet so we can change the window view
.Select
'If you are in Page Break Preview Or Page Layout view go
'back to normal view, we do this for speed
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
'Turn off Page Breaks, we do this for speed
.DisplayPageBreaks = False
'Set the first and last row to loop through
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'We loop from Lastrow to Firstrow (bottom to top)
For Lrow = 9 To Lastrow Step 1
'We check the values in the A column in this example
With .Cells(Lrow, "C")
If Not IsError(.Value) Then
If Cells(Lrow, "D").Value = "Total" Then
GoTo y
End If
If .Value = Sheet1.Cells(2, 6) Then
r = r + 1
End If
If .Value <> Sheet1.Cells(2, 6) Then
If .Value = "" Then
r = 0
End If
prow = Lrow - r
If Cells(prow, "C").Value = Sheet1.Cells(2, 6) Then
r = r + 1
GoTo x
End If
.EntireRow.ClearContents
'This will delete each row with the Value "ron"
'in Column A, case sensitive.
x:
End If
End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
y:
Range(Cells(9, 3), Cells(Lrow, 3)). _
SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'xxxxxxxxxxxxxxxxxx
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "hadi#siemens.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
'.Send 'or use
.Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

You are trying to run a property only supported on a specified sheet, on multiple sheets at once. This is not supported, hence the error 438.
You can try to loop these sheets:
For Each ws In Destwb.Sheets
If ws.Name = "REC_INT" or ws.Name = "REC_EXT" then
Destwb.Worksheets(ws.Name).DisplayPageBreaks = False
End if
Next ws
I think you don't need to check for the sheets names, as you copy just the two of them into a new workbook.

Related

Autofilter with .Sheets(Array)

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
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.

Fetching email addresses with email domain cell value

I fetch email addresses from my Outlook account.
Now I am trying to fetch only specific email address from inbox e.g. Gmail.com that returns gmail addresses only.
I modified the code where I used array to store the addresses temporarily and then compare to string. After altering the code it returns nothing (not even errors).
Option Explicit
Sub GetInboxItems()
Dim ol As outlook.Application
Dim ns As outlook.Namespace
Dim fol As outlook.Folder
Dim I As Object
Dim mi As outlook.MailItem
Dim N As Long
Dim val As String
Dim MyArray() As String, MyString As String, J As Variant, K As Integer
Dim MyAs As Variant
Dim Awo As Variant
MyString = Worksheets("Inbox").Range("D1")
MyArray = Split(MyString, ";")
Application.ScreenUpdating = False
Set ol = New outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)
'Dim inputSheet As Worksheet
'Dim aCellOnInputSheet As Range
'Dim inputDateCell As Range
'Dim userSheetName As String
'Set cod = ThisWorkbook.Worksheets("Inbox")
'Set aCellOnInputSheet = cod.Range("D1")
'userSheetName = aCellOnInputSheet.Value
Range("A3", Range("A3").End(xlDown).End(xlToRight)).Clear
N = 2
For Each I In fol.Items
If I.Class = olMail Then
Set mi = I
N = N + 1
If mi.SenderEmailType = "EX" Then
MyAs = Array(mi.Sender.GetExchangeUser().PrimarySmtpAddress)
For Each Awo In MyAs
If InStr(MyString, Awo) > 0 Then
Cells(N, 1).Value = mi.Sender.GetExchangeUser().PrimarySmtpAddress
Cells(N, 2).Value = mi.SenderName
Exit For
End If
Next
' Cells(N, 1).Value = mi.Sender.GetExchangeUser().PrimarySmtpAddress
' Cells(N, 2).Value = mi.SenderName
Else
MyAs = Array(mi.SenderEmailAddress)
For Each Awo In MyAs
If InStr(MyString, Awo) > 0 Then
Cells(N, 1).Value = mi.SenderEmailAddress
Cells(N, 2).Value = mi.SenderName
Exit For
End If
Next
End If
End If
Next I
Application.ScreenUpdating = True
End Sub
Fetching all email addresses will be problematic. I don't want to expose any email domains other than the defined ones.
Minimal changes to manipulating the row n and switching the variables in Instr should be sufficient.
This also shows how to drop the array if one domain.
Option Explicit
Sub GetInboxItems_SingleDomain()
' Early binding - reference to Microsoft Outlook XX.X Object Library required
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.Folder
Dim folItm As Object
Dim mi As Outlook.MailItem
Dim n As Long
Dim myString As String
Dim myAddress As String
myString = Worksheets("Inbox").Range("D1") ' gmail.com
'Debug.Print myString
Application.ScreenUpdating = False
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)
Range("A3", Range("A3").End(xlDown).End(xlToRight)).Clear
n = 3
' If slow, limit the number of items in the loop
' e.g. https://stackoverflow.com/questions/21549938/vba-search-in-outlook
' strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:fromemail" & Chr(34) & " like '%" & myString & "'"
For Each folItm In fol.Items
If folItm.Class = olMail Then
Set mi = folItm
If mi.SenderEmailType = "EX" Then
myAddress = mi.Sender.GetExchangeUser().PrimarySmtpAddress
Else
myAddress = mi.SenderEmailAddress
End If
'Debug.Print myAddress
'The bigger text on the left
' In general, not necessarily here, keep in mind case sensitivity
If InStr(LCase(myAddress), LCase(myString)) > 0 Then
Cells(n, 1).Value = myAddress
Cells(n, 2).Value = mi.SenderName
n = n + 1
End If
End If
Next folItm
Application.ScreenUpdating = True
Debug.Print "Done."
End Sub

Looping through files in a folder to change formulas to values

I'm working on a macro that loops through all files in a folder, changes formulas that point to other workbooks to values, and saves and closes each file. I've merged two pieces of code from Ron de Bruin into the below macro. His code to break links and change to values works perfectly when it isn't in the loop but when I run this macro the files then don't have the info, they instead return "#N/A". What am I doing wrong?
Sub Formulas()
Const strSavePath As String = “MyFilePath"
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String, Fnum As Long
Dim mybook As Workbook
Dim CalcMode As Long
Dim sh As Worksheet
Dim ErrorYes As Boolean
Dim Path1 As Range
Set Path1 = ThisWorkbook.Worksheets("Monthly Reporting").Range("E2")
Dim WorkbookLinks As Variant
Dim i As Long
MyPath = strSavePath & Path1 & "\"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
'Change cell value(s) in one worksheet in mybook
WorkbookLinks = mybook.LinkSources(Type:=xlLinkTypeExcelLinks)
If IsArray(WorkbookLinks) Then
For i = LBound(WorkbookLinks) To UBound(WorkbookLinks)
mybook.BreakLink _
Name:=WorkbookLinks(i), _
Type:=xlLinkTypeExcelLinks
Next i
Else
MsgBox "No Links to other workbooks"
End If
If Err.Number > 0 Then
ErrorYes = True
Err.Clear
'Save and close mybook
mybook.Close savechanges:=True
End If
On Error GoTo 0
Else
'Not possible to open the workbook
ErrorYes = True
End If
Next Fnum
End If
If ErrorYes = True Then
MsgBox "There are problems in one or more files, possible problem:" _
& vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
End If
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub

If data doesn't exist add to bottom of list

Basically I'm working on a excel document which copies values from this workbook into another if they match. So if they have the same ID and a "yes" then a field is updated. However in some instances it may be that the ID doesn't exist in the workbook im copying to, but if there is a "yes" I would like to add it to the next empty row.
Below is what I have so far
Dim fpath As String
Dim owb As Workbook
Dim thisone As String
Dim Siteref(1000) As String, siteref2(1000) As String, sitename(1000) As String, sitename2(1000) As String
fpath = "my file path"
Set owb = Application.Workbooks.Open(fpath) 'open location and file
Dim Master As Worksheet 'declare both
Dim Slave As Worksheet
Set Slave = owb.Worksheets("Schedule") 'sheet in workbook im copying too
Set Master = ThisWorkbook.Worksheets("Tbl_Primary") 'sheet from workbook im in
For i = 1 To 1000 '(the slave sheet) 'for first 1000 cells
For j = 1 To 1000 '(the master sheet)
If Master.Cells(j, 2).Value = "" Then
GoTo lastline
End If ' if ID cell is blank jump to last line
If Master.Cells(j, 2).Value = Slave.Cells(i, 1).Value And Master.Cells(j, 65).Value = "Yes" Then
Slave.Cells(i, 4).Value = Master.Cells(j, 18).Value 'If the ID equals that in the slave sheet and there is a yes ticked the copy address
End If
lastline:
Next
Next
MsgBox ("Data Transfer Successful")
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Tbl_Primary").Delete 'delete sheet
Application.DisplayAlerts = True
ThisWorkbook.Save
ThisWorkbook.Close 'save and close it
Give this one a try and let me know if it works. I wrote it "blind" without testing. So, I am not entirely sure it will work:
Dim bolFound As Boolean
Dim lngLastRow As Long
Dim fpath As String
Dim owb As Workbook
Dim Master As Worksheet 'declare both
Dim Slave As Worksheet
fpath = ActiveWorkbook.Path
Set owb = Application.Workbooks.Open(fpath) 'open location and file
Set Master = ThisWorkbook.Worksheets("Tbl_Primary") 'sheet from workbook im in
Set Slave = owb.Worksheets("Schedule") 'sheet in workbook im copying too
'
lngLastRow = Slave.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For j = 1 To 1000 '(the master sheet)
bolFound = False
For i = 1 To 1000 '(the slave sheet) 'for first 1000 cells
If Trim(Master.Cells(j, 2).Value2) = vbNullString Then Exit For 'if ID cell is blank jump to last line
If Master.Cells(j, 2).Value = Slave.Cells(i, 1).Value And _
Master.Cells(j, 65).Value = "Yes" Then
Slave.Cells(i, 4).Value = Master.Cells(j, 18).Value 'If the ID equals that in the slave sheet and there is a yes ticked the copy address
bolFound = True
End If
Next
If bolFound = False And _
Master.Cells(j, 65).Value = "Yes" Then
Slave.Cells(lngLastRow, 4).Value = Master.Cells(j, 18).Value 'adding the new entry to the list
lngLastRow = lngLastRow + 1
End If
Next
MsgBox ("Data Transfer Successful")
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Tbl_Primary").Delete 'delete sheet
Application.DisplayAlerts = True
ThisWorkbook.Save
ThisWorkbook.Close 'save and close it
NOT tested.
Dim fpath As String
Dim owb As Workbook
Dim thisone As String
Dim Siteref(1000) As String, siteref2(1000) As String, sitename(1000) As String, sitename2(1000) As String
Dim lastRow As Long
fpath = "my file path"
Set owb = Application.Workbooks.Open(fpath) 'open location and file
Dim Master As Worksheet 'declare both
Dim Slave As Worksheet
Set Slave = owb.Worksheets("Schedule") 'sheet in workbook im copying to
Set Master = ThisWorkbook.Worksheets("Tbl_Primary") 'sheet from workbook im in
For i = 1 To 1000 '(the slave sheet) 'for first 1000 cells
For j = 1 To 1000 '(the master sheet)
If Master.Cells(j, 2).Value = "" Then
Exit For
End If ' if ID cell is blank jump to last line
If Master.Cells(j, 2).Value = Slave.Cells(i, 1).Value And Master.Cells(j, 65).Value = "Yes" Then
'If the ID equals that in the slave sheet and there is a yes ticked the copy address
Slave.Cells(i, 4).Value = Master.Cells(j, 18).Value
End If
If Master.Cells(j, 65).Value = "Yes" Then
lastRow = Slave.Cells(ActiveSheet.Rows.Count, "D").End(xlUp).Row
'if yes found, copy value
Slave.Cells(lastRow + 1, 4).Value = Master.Cells(j, 18).Value
End If
Next
Next
MsgBox ("Data Transfer Successful")
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Tbl_Primary").Delete 'delete sheet
Application.DisplayAlerts = True
ThisWorkbook.Save
ThisWorkbook.Close 'save and close it

Excel VBA How to open more workbook using array?

i have a job which i need to merge 4 files together. May i know what if i have more files in coming future to merge, instead keying the "open workbook"code. What kind of method should i use? and yet meet the lowest line merge criteria as well. Below is the code i have attempt so far
Sub GetFile()
Dim Book1Path As Variant, Book2Path As Variant, Book3Path As Variant, Book4Path As Variant
Dim SourceWB As Workbook, DestWB As Workbook
Dim lRow As Long
Dim ws1, ws2, ws3, ws4 As Worksheet
Dim c3ll1, c3ll2, c3113, c3114, range1, range2, range3, range4 As Range
'## Open both workbook first:
Book1Path = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLS), *.XLS", Title:="Chapter 1")
If Book1Path = False Then Exit Sub
Set SourceWB = Workbooks.Open(Book1Path)
Book2Path = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLS), *.XLS", Title:="Chapter 2")
If Book2Path = False Then Exit Sub
Set DestWB = Workbooks.Open(Book2Path)
Book3Path = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLS), *.XLS", Title:="Chapter 3")
If Book3Path = False Then Exit Sub
Set DestWB = Workbooks.Open(Book3Path)
Book4Path = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLS), *.XLS", Title:="Chapter 4")
If Book4Path = False Then Exit Sub
Set DestWB = Workbooks.Open(Book4Path)
'Copy.
With SourceWB.Sheets("Report")
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("A2:F" & lRow).Copy
End With
'Active Merge Workbook
ThisWorkbook.Activate
'Paste.
Columns("A").Find("", Cells(Rows.Count, "A")).Select
Selection.PasteSpecial
'Active CWPI Topic 1 Assessment Workbook
SourceWB.Activate
'Copy.
With SourceWB.Sheets("Report")
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("G2:G" & lRow).Copy
End With
'Active Merge Workbook
ThisWorkbook.Activate
'Paste.
Columns("G").Find("", Cells(Rows.Count, "G")).Select
Selection.PasteSpecial
Set ws1 = SourceWB.Sheets("Report")
Set ws2 = DestWB.Sheets("Report")
Set ws3 = DestWB.Sheets("Report")
Set ws4 = DestWB.Sheets("Report")
lastrow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
Set range2 = ws2.Range("A2:A" & lastrow2)
lastrow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Set range1 = ws1.Range("A2:A" & lastrow1)
For Each c3ll2 In range2
a = 0
activerow2 = c3ll2.Row
For Each c3ll1 In range1
If c3ll1.Value = c3ll2.Value Then
activerow1 = c3ll1.Row
Cells(activerow1, "H") = ws2.Cells(activerow2, 3)
Cells(activerow1, "I") = ws2.Cells(activerow2, 4)
Cells(activerow1, "J") = ws2.Cells(activerow2, 5)
Cells(activerow1, "K") = ws2.Cells(activerow2, 6)
Cells(activerow1, "L") = ws2.Cells(activerow2, 7)
a = 1 'Username is found
Exit For
End If
Next c3ll1
If a = 0 Then 'If Username is not found print at end
lastrow1 = lastrow1 + 1
Cells(lastrow1, "A") = ws2.Cells(activerow2, 1)
Cells(lastrow1, "B") = ws2.Cells(activerow2, 2)
Cells(lastrow1, "H") = ws2.Cells(activerow2, 3)
Cells(lastrow1, "I") = ws2.Cells(activerow2, 4)
Cells(lastrow1, "J") = ws2.Cells(activerow2, 5)
Cells(lastrow1, "K") = ws2.Cells(activerow2, 6)
Cells(lastrow1, "L") = ws2.Cells(activerow2, 7)
End If
Next c3ll2
'Columns Width Autofit
ActiveSheet.Columns.AutoFit
With Application
Cells(.CountA(Columns("A:A")) + 1, 1).Select
.ScreenUpdating = True
.DisplayAlerts = False
SourceWB.Close
DestWB.Close
End With
End Sub
So...you're looking for a loop to open up more workbooks in an easy way? Right now, you are not opening 3 versions of DestWB like you think you are. You are instead overwriting DestWB each time you call...
Set DestWB = Workbooks.Open(BookXPath)
I would replace your three blocks that open the path, check the path, and then open the path to the workbook DestWB with the following:
'Create an array of paths, and a corresponding array of workbooks
Dim paths() As String, wbs() as Workbook
ReDim paths(3)
'ReDim wbs to the same as path so its easier to adjust in the future
ReDim wbs(UBound(paths))
'Set your paths, then loop through them to assign your workbooks
Dim x as Integer
For x = 1 To UBound(paths)
paths(x) = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLS), *.XLS", Title:="Chapter " + CStr(x))
If paths(x) = "False" Then
Exit Sub
End If
Set wbs(x) = Workbooks.Open(paths(x))
Next x
You can use the same loop methodology to do the other tasks in this macro. You can also eliminate all your activating of the ThisWorkbook by setting it as a variable.
Dim thisWB as Workbook
Set thisWB = ThisWorkbook
This will in turn let you clean up this code...
Columns("A").Find("", Cells(Rows.Count, "A")).Select
Selection.PasteSpecial
Into this code...
thisWB.Sheets("SOMESHEET").Columns("A").Find("", Cells(Rows.Count, "A")).PasteSpecial
In general .Select and Selection should be avoided. Search around stackoverflow and Google, there are plenty of examples for both loops and eliminating .Select and Selection.

Resources