Run time error 1004

Question

Hi, I am a newbies in VBA. With the code attached, I have encountered the run time error 1004 with message Application defined or object defined error. Appreciate your helps. Thanks alot

 

Sub Copy_To_Workbooks()
    Dim CalcMode As Long
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim WSNew As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim Lrow As Long
    Dim foldername As String
    Dim MyPath As String
    Dim FieldNum As Integer
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim NewFn As String
    NewFn = Format(Sheets("Rpt_BkgTrend").Range("C2"), "yymmdd")
   
    Dim ws3 As Worksheet
    Dim ws4 As Worksheet
    Dim WsNew1 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim wb As Workbook
   
   
    'Name of the sheet with your data
    Set ws1 = Sheets("Rpt_BkgTrend")  '<<< Change
    Set ws3 = Sheets("Rpt_DepMth")
   
  
    'Determine the Excel version and file extension/format
    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007
        If ws1.Parent.FileFormat = 56 Then
            FileExtStr = ".xls": FileFormatNum = 56
        Else
            FileExtStr = ".xlsx": FileFormatNum = 51
        End If
    End If

    'Set filter range : A9 is the top left cell of your filter range and
    'the header of the first column, V is the last column in the filter range
    Set rng = ws1.Range("A9:V" & Rows.Count)
    Set rng1 = ws3.Range("A9:AE" & Rows.Count)
     
   
    'Set Field number of the filter column
    'Field:=1 is column A, 2 = column B, ......
    FieldNum = 1

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    ' Add worksheet to copy/Paste the unique list
    Set ws2 = Worksheets.Add
   

    MyPath = "C:\Documents and Settings\jc\Desktop\Working"

    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    'Create folder for the new files
    foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
    MkDir foldername

    With ws2
        'first we copy the Unique data from the filter field to ws2
        rng.Columns(FieldNum).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("A1"), Unique:=True
        rng1.Columns(FieldNum).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("A1000"), Unique:=True
        
        'Replace value
        Cells.Replace What:="Market", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
       
        'Sort data
        ws2.Range("A1:A2000").Sort _
        Key1:=ws2.Range("A1")
       
       
        Set rng2 = ws2.Range("A1:A" & Rows.Count)
        rng2.Columns(FieldNum).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("B1"), Unique:=True
               
        Set rng3 = ws2.Range("B2:B" & Rows.Count)
        rng3.Columns(FieldNum).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("C1"), Unique:=True
       
       
        'loop through the unique list in ws2 and filter/copy to a new workbook
        Lrow = .Cells(Rows.Count, "C").End(xlUp).Row
        For Each cell In .Range("C2:C" & Lrow)

            'Add new workbook with 2 sheets
            
            Set wb = Workbooks.Add(1)
       
            Set WSNew = wb.Worksheets.Add
            WSNew.Name = "Rpt_BkgTrend_Market"
            Set WsNew1 = wb.Sheets("Sheet1")
            WsNew1.Name = "Rpt_DepMth_Market"
           
               
            'Firstly, remove the AutoFilter
            ws1.AutoFilterMode = False
            ws3.AutoFilterMode = False
           

            'Filter the range
            rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value
            rng1.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value
           
            'Copy the Header 1 to 8
            ws1.Rows("1:8").Copy
            With WSNew.Range("A1")
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
            End With
           
            ws1.AutoFilter.Range.Copy
            With WSNew.Range("A9")
                ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
                .Select
            End With
           
            Application.CutCopyMode = False
             
           
            ws3.Activate
           
            'Copy the Header 1 to 8
            ws3.Rows("1:8").Copy
            With WsNew1.Range("A1")
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
            End With
           
            ws3.AutoFilter.Range.Copy
            With WsNew1.Range("A9")
                ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
                .Select
            End With
           
            Application.CutCopyMode = False
           

          
           
           'Save the file in the new folder and close it
           'WSNew.Parent.SaveAs foldername & NewFn & "_" _
            '     & cell.Value & FileExtStr, FileFormatNum
           'WSNew.Parent.Close False

            wb.SaveAs foldername & NewFn & "_" _
                 & cell.Value & FileExtStr, FileFormatNum
           
                       
                       
            'Close AutoFilter
           ws1.AutoFilterMode = False
           ws3.AutoFilterMode = False

        Next cell

        'Delete the ws2 sheet
        On Error Resume Next
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
        On Error GoTo 0

    End With

    MsgBox "Look in " & foldername & " for the files"

    With Application
        .ScreenUpdating = True
        .Calculation = CalcMode
    End With

End Sub

 

 

Answer 1

Can you let us know which line gives you the error.

Answer 2

I am having the same problem with a macro in the workbook. I have included the code with error in code block.

 

Sub Save_New_Excel_File(Folder_Name As String, File_Name As String)
    Dim Vendor As String
    Dim Temp_Folder As String
    Dim TheDate
    Dim TheTime, TheHour
    Dim WB As Workbooks
    Set WB = Application.Workbooks
   
    Vendor = Left(File_Name, Len(File_Name) - 4)
   
    ' Get the date and time to add to the XLS filename
    TheHour = Hour(Time)
    If TheHour > 13 Then
        TheHour = TheHour - 12
    End If
   
    TheTime = TheHour & "-" & Minute(Time)
    TheDate = "-" & Month(Date) & "-" & Day(Date) & "-" & TheTime
      

Code Snippet

    WB.Open FileLocation & "\Master.xls"

 

 

    WB.Application.DisplayAlerts = False
    Worksheets("PPI 2").Visible = False
   
    If INI_Exists Then
        ActiveWorkbook.SaveCopyAs Folder_Name & Vendor & TheDate & ".xls"
    Else
        ' Example = \\server\Global-backup\ Docs
        Temp_Folder = "\\server\Global-backup\" & UserName & "'s Docs\Board Orders\"
        'Temp_Folder = "\\server1\C-Drive\Layouts\" & UserName & "'s Docs\"
        ActiveWorkbook.SaveCopyAs Temp_Folder & Vendor & TheDate & ".xls"
    End If
   
    WB("MASTER.XLS").Close SaveChanges = False
   
    If INI_Exists Then
        WB.Open Folder_Name & Vendor & TheDate & ".xls"
    Else
        WB.Open Temp_Folder & Vendor & TheDate & ".xls"
    End If
   
    Enter_Data_Cells Vendor, Folder_Name
   
    WB(Vendor & TheDate & ".xls").Save
    'WB(Vendor & ".xls").Close
   
End Sub

Answer 3

Hi

 

One possibility is that the file is not available in required location. Vatriable 'FileLocation ' in the code does not have any value!

 

Code Snippet

If Len(Dir(FileLocation & "\Master.xls")) <> 0 Then
       WB.Open FileLocation & "\Master.xls"
   Else
       MsgBox "File Not Available in required location!"
       Exit Sub
   End If

 

 

You can use the above code to check for the same

 

(http://vbadud.blogspot.com/2008/05/excel-vba-1004-file-could-not-be.html)

 

Cheers

Shasur