VBA Run time Error and Unreadable file

[ziad alsayed]

Dear all
I hope you can assist me in this case as usual. I will try to summarize. I hope I am not asking too much.
I have a list of customer which I prepare on monthly basis, so on my workbook I have all the month.
I am using the advanced filter by salesman to get his list of customer, copy it to a new workbook which have only one sheet named “Summary” (as a beginning) and email to the salesman. My code is working if I do it for only one month. So I will have in this workbook the added month sheet and the summary sheet.
But if I try to run the code for any other month I receive the below message
“run-time error ‘1004’ method open of object workbooks failed”<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
now if I try to open the workbook that I created I will receive the below note
“ Excel Found Unreadable content in ‘ ziad.xlsm’ . do you want to recover the content of this workbook?, if you trust the source if this workbook , click yes. “<o></o>
Note that after clicking yes and opening the workbook , I will see all the information for the two month and the Summary shhet with the comparison as I design it.
Below is my code for one salesman , I am looping through all salesman but the code will be two long to paste on the board.
Note: will you see the code the macro “findfiles2007” , which is assisting me in listing the path of each workbook to re open it.
[
Sub FilterMCBySalesman()
Dim irange As Range
Dim orange As Range
Dim crange As Range
Dim wbo As Workbook
Dim wbn As Workbook
Dim wsn As Worksheet
Dim wso As Worksheet
Dim wsl As Worksheet
Dim omail As Object
Dim oapp As Object
Dim Msg As String
'select the worksheet
' before running this macro change the below name to the current Month
Set wbo = ActiveWorkbook
Set wso = Worksheets("MC Monthly Update_November")
'delete any previous data after from L column till the end
Range("L1:AZ1").EntireColumn.Delete
'define the size of the data set, in advanced filter you have to define the last row and the last column in the dateset
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
nextcol = Cells(1, Columns.Count).End(xlToLeft).Column + 2 ' the +2 is to put the data 2 columns after the last column.
' copy heading of output range
Range("A1").Copy Destination:=Cells(1, nextcol)
' set the output range as first step for the advanced filer
Set orange = Cells(1, nextcol)
' set the input range is the second step
Set irange = Range("A1").Resize(finalrow, nextcol - 2)
' do the advanded filter with a unique list and without any criteria
irange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:="", Copytorange:=orange, unique:=True
' need to loop through the salesman in nexcol which in "M" column , so first i have to find the last the salesman
finalsm = Cells(Rows.Count, nextcol).End(xlUp).Row
' loop through each customer
For Each cell In Cells(2, nextcol).Resize(finalsm - 1, 1)
thissm = cell.Value
' put heading again
Cells(1, nextcol + 2) = Range("M1")
Cells(2, nextcol + 2) = thissm
Set crange = Cells(1, nextcol + 2).Resize(2, 1)
' copy the heading
Range("B1:K1").Copy Destination:=Cells(1, nextcol + 4)
'set output range
Set orange = Cells(1, nextcol + 4).Resize(1, 10)
' do advanced filter to get unique list of salesman
irange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=crange, Copytorange:=orange
'select Q1 this will assist in copying the current region
Range("Q1").Select
' after the advance filter, i will check the workbook related to it, open and the current month, format it and close.
' i will add a worksheet before the summary sheet, name base on cells(3,1) which if got by a formula, i will rearrange the sheet by using array formula
'now i will compare the last 2 month by taking the data to summary sheet then sorting it and start removing duplicate.
If thissm = "Apapa" Then
'open the workbook
ChDir "C:\"
Workbooks.Open Filename:="C:\Users\dv7\Desktop\Maintenance\MCFilter\Apapa.xlsm", UpdateLinks:=0
'add a sheet before summary sheet
Set wsn = Sheets.Add(before:=Worksheets("Summary"))
Set wbn = ActiveWorkbook
'add title ,merge style, and wrap text
wsn.Cells(1, 1) = " Maintenance Contract Report By Salesman"
wbn.Styles.Merge Workbook:=Workbooks("MC_End_Users_2010.xlsm")
wsn.Cells(1, 1).Style = "MAZ_Heading"
wsn.Cells(1, 1).WrapText = False
'add the salesman name
wsn.Cells(2, 1) = thissm
wsn.Cells(2, 1).Style = "MAZ_Heading"
' copy the information from old workbook to new workbook
wso.Cells(1, nextcol + 4).CurrentRegion.Copy Destination:=wsn.Cells(4, 1)
wsn.Cells.EntireColumn.AutoFit
'adding formula for the date
Cells(3, 1).FormulaR1C1 = "=EOMONTH(TODAY(),0)-31"
'format the cell
With Cells(3, 1)
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Cells(3, 1).NumberFormat = "mmmm"
' copy and paste value
Cells(3, 1).Copy
Cells(3, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
' name the sheet base on the date
wsn.Name = Format(Range("A3").Value, "mmmm")
' find final row on sheet
rowcalc = Cells(Rows.Count, 1).End(xlUp).Row
'sort worksheets
arr = Array("January", "February", "March", "April", "May", "June", "July", _
"August", "September", "October", "November", "December", "Summary")
For w = LBound(arr) To UBound(arr)
On Error Resume Next
Sheets(arr(w)).Move After:=Sheets(Sheets.Count)
On Error GoTo 0
Next w
' set up the summary sheet and delete the old data
Set wss = wbn.Worksheets("Summary")
wss.Select
Cells(1, 1).Resize(Rows.Count, Columns.Count).Delete
' find the last two sheet before Summary sheet
f = Sheets("Summary").Index
If f > 2 Then
Sheets(f - 1).Select
' add the word "won" for the new added sheet and resize
Cells(5, 11).Resize(rowcalc - 4, 1) = "Won"
' copy all the data to summary sheet
Cells(4, 1).Resize(rowcalc, 11).Copy Destination:=wss.Cells(1, 1)
rowcomparaison = wss.Cells(Rows.Count, 1).End(xlUp).Row
' select previous month
Sheets(f - 2).Select
' add the word "lost" for the new added sheet and resize
Cells(5, 11).Resize(rowcalc - 5, 1) = "Lost"
' copy all date to the summary sheet
Cells(5, 1).Resize(rowcalc, 11).Copy Destination:=wss.Cells(rowcomparaison + 1, 1)
'sort data in column g from A to Z, this is on summary sheet
wss.Select
Range("G1").Select
wss.Sort.SortFields.Add Key:=Range("G1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With wss.Sort
.SetRange Range("A1:K1000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' autofit columns
Range("A:K").EntireColumn.AutoFit
'delete duplicates data, this is a loop to check two consecutive rows
wss.Select
finalsummaryrow = wss.Cells(Rows.Count, 1).End(xlUp).Row
For C = finalsummaryrow To 2 Step -1
If Cells(C, 7) = Cells(C - 1, 7) Then
Cells(C, 1).EntireRow.Delete
Cells(C - 1, 1).EntireRow.Delete
End If
Next C
Columns("A:K").AutoFit
' delted the added column to data "Won" and "Lost", on the other sheets and not on the summary sheet
Sheets(f - 1).Select
Columns("K:K").Delete
Sheets(f - 2).Select
Columns("K:K").Delete
wss.Select
Range("A1").Select
End If
' save the workbook
fn = thissm & ".xlsm"
fp = wbo.Path & Application.PathSeparator & "MCFilter" & Application.PathSeparator
Application.DisplayAlerts = False
wbn.SaveAs Filename:=fp & fn
wbn.Close savechanges:=False
<o> </o>
wso.Select
Set wbn = Nothing
Set wsn = Nothing
' clear the output range area to add another salesman on old workbook
Cells(1, nextcol + 2).Resize(1, 12).EntireColumn.Clear
'******************************************************************************
Next cell
add worksheets to list the path of each wbn
Set wsl = wbo.Worksheets.Add(before:=Worksheets("Reports_June"))
' list folder
FindFiles2007
'find last row in wsl
lastrow = wsl.Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To lastrow
' name the variable
thisfile = wsl.Cells(j, 1)
'On Error Resume Next
'open all the workbooks
' i am getting the run time error on the below code,it only happen when i run thesecond time.
Set wbn = Workbooks.Open(Filename:=thisfile)
Set oapp = CreateObject("outlook.application")
Set omail = oapp.createitem(0)
' check them one by one
If wbn.Name = "Apapa.xlsm" Then
Application.StatusBar = " Sending mail to Mazen"
With omail
.To = "mazen.loutfi@jubailibros.com"
.Subject = "Your Update Maintenance Contract In PHC" & " " & Format$(Date, "dd ,mmmm,yyyy")
.attachments.Add wbn.FullName
'compose msg
Msg = "Dear" & " " & "Mazen" & vbCrLf & vbCrLf
Msg = Msg & "Please find attched file, "
Msg = Msg & " If you have any Comment don't Hesitate to reply me."
Msg = Msg & vbCrLf & vbCrLf
Msg = Msg & "Regards" & vbCrLf
Msg = Msg & "Ziad Alsayed"
.body = Msg
.send
End With
wbn.Close savechanges:=False
end if
next j
Set omail = Nothing
Set oapp = Nothing
' delete wsl
Application.DisplayAlerts = False
wsl.Delete
wso.Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Below is the findfiles2007
Sub FindFiles2007()
' New method for Excel 2007
' You need this macro, plus the following macro
Dim fso As Object
Dim strName As String
Dim strArr(1 To 1048576, 1 To 1) As String, i As Long
' Enter the folder name here,
Const strDir As String = "C:\Users\dv7\Desktop\Maintenance\MCFilter\"
Let strName = Dir$(strDir & "*.xlsm")
Do While strName <> vbNullString
Let i = i + 1
Let strArr(i, 1) = strDir & strName
Let strName = Dir$()
Loop
Set fso = CreateObject("Scripting.FileSystemObject")
Call recurseSubFolders(fso.GetFolder(strDir), strArr(), i)
Set fso = Nothing
If i > 0 Then
Range("A1").Resize(i).Value = strArr
End If
' Next, loop through all found files
' and break into path and filename
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To finalrow
ThisEntry = Cells(i, 1)
For j = Len(ThisEntry) To 1 Step -1
If Mid(ThisEntry, j, 1) = Application.PathSeparator Then
Cells(i, 2) = Left(ThisEntry, j)
Cells(i, 3) = Mid(ThisEntry, j + 1)
Exit For
End If
Next j
Next i

End Sub
Private Sub recurseSubFolders(ByRef Folder As Object, _
ByRef strArr() As String, _
ByRef i As Long)
Dim SubFolder As Object
Dim strName As String
For Each SubFolder In Folder.SubFolders
Let strName = Dir$(SubFolder.Path & "*.jpg")
Do While strName <> vbNullString
Let i = i + 1
Let strArr(i, 1) = SubFolder.Path & strName
Let strName = Dir$()
Loop
Call recurseSubFolders(SubFolder, strArr(), i)
Next
End Sub

<o> </o>
<o> </o>
code]
appreciate any help