Visual Basic run-time error 1004 work around

[midori323]

Hi, guys,

I was trying to extract data from multiple Excel workbook using VBA and since the target cells to extract data is only 2,
I thought it's fairly straightforward code...and wrote the code below:

Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
MyFile = Dir("C:\Users\ahozumi\Desktop\Business sheet\")
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsm" Then
Exit Sub
End If
Workbooks.Open (MyFile)
Range("A5,K27").Copy
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("sheet1").Range(Cells(erow, 1), Cells(erow, 2))
MyFile = Dir
Loop
End Sub

And when I ran this code, I got this "run-time error 1004"....indicating the file
couldn't be found.
Somehow, it even specified the file name in the folder("BRTwk25.xlsx")and stated this file cannot be found...

Can anyone advise me how to fix this error?


Thanks in advance!


Midori323

[Kenneth Hobs]

You need to prefix the foldername (concatenate) to the filename. e.g.

Workbooks.Open "C:\Users\ahozumi\Desktop\Business sheet\" & MyFile

[midori323]

Thank you, Kenneth,

I changed the 9th line and now the problem of opening the target file has been fixed....
But now I have the problem of defining the target cells to copy...
I've got a couple of error messages relating to line 10,,, "Range ("A5, K27").Open
So I changed it and now the code is revised as per below:

Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
MyFile = Dir("C:\Users\ahozumi\Desktop\Business sheet\")
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsm" Then
Exit Sub
End If
Workbooks.Open "C:\Users\ahozumi\Desktop\Business sheet\" & MyFile
Range(Cells(5, 1), Cells(27, 11)).Copy
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("sheet1").Range(Cells(erow, 1), Cells(erow, 2))
MyFile = Dir
Loop

And I still get this run time error 1004, stating "paste method of worksheet class failed"..
How can I fix this problem..?

Any suggestion or recommendation is appreciated!

Midori323

[Kenneth Hobs]

Please paste code between code tags. Type them or click the # icon on the toolbar to insert them. It is easy to troubleshoot and help that way.

I prefer Range over Cells most time as Range allows intellisense to work. As such, when you type the period after the Range object, you would see that there is no Open method. For you paste range, cells would be fine. You many need a WorksheetFunction.Transpose though.

You may want to add False after the ActiveWorkbook.Close. Your Copy/Paste can be on one line. It might go something like:

erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Workbooks.Open CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Business sheet\" & MyFile
Range("A5,K27").Copy ThisWorkbook.Sheet1.Range(Cells(erow, "A"), Cells(erow, "B"))
ActiveWorkbook.Close False

[midori323]

Hi, Kenneth,

Thank you for your advice.

I've never used CreateObject or WScript but used them to replace my previous code.
Now it looks like

Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
MyFile = Dir("C:\Users\ahozumi\Desktop\Business sheet\")

Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsm" Then
Exit Sub
End If

erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Workbooks.Open CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Business sheet\" & MyFile
Range("A5", "K27").Copy ThisWorkbook.Sheet1.Range(Cells(erow, "A"), Cells(erow, "B"))

ActiveWorkbook.Close False

    
Loop


End Sub

But now I've got Compile error saying "Method or data member not found".
I thought I need Paste command but when I tried to insert .Paste
after .Copy, I got compile error...

So I used

 ActiveSheet.Paste Destination:=Worksheets("sheet1").Range(Cells(erow, 1), Cells(erow, 2))

But again I got compile error...

Where should I insert paste command in this case..?


Thank you for your help.

Midori

[Kenneth Hobs]

I am not a big fan of mixing sheet code and sheet names. This might be a bit more simple.

Sub LoopThroughDirectory()  
  Dim MyFile As String, erow As Long, ws As Worksheet
  
  MyFile = Dir(CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Business sheet\")
   
  Set ws = ThisWorkbook.Worksheets("Sheet1")
   
  Do While Len(MyFile) > 0
    If MyFile = "zmaster.xlsm" Then
      Exit Sub
    End If
     
    erow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Workbooks.Open CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Business sheet\" & MyFile
    Range("A5", "K27").Copy ws.Range(Cells(erow, "A"), Cells(erow, "B"))
     
    ActiveWorkbook.Close False
  Loop
End Sub

[midori323]

I am not a big fan of mixing sheet code and sheet names. This might be a bit more simple.

Sub LoopThroughDirectory()  
  Dim MyFile As String, erow As Long, ws As Worksheet
  
  MyFile = Dir(CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Business sheet\")
   
  Set ws = ThisWorkbook.Worksheets("Sheet1")
   
  Do While Len(MyFile) > 0
    If MyFile = "zmaster.xlsm" Then
      Exit Sub
    End If
     
    erow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Workbooks.Open CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Business sheet\" & MyFile
    Range("A5", "K27").Copy ws.Range(Cells(erow, "A"), Cells(erow, "B"))
     
    ActiveWorkbook.Close False
  Loop
End Sub

[midori323]

Thank you again, Kenneth,

I tried to use your code and now I have an error message on the fourth line..i.e.,

Set ws =ThisWorkbook.Worksheets("Sheet1")

The error message I got this time was "compile error: End of statement"
So I added semi colon on the left side of the equation but still get the
same error message....

I rewrote the code as
[CODE]
Dim ws As Worksheet[
ws=ThisWorksbook.Worksheet("Sheet1")
/CODE]

But didn't work either...

I don't know why it didn't work and I really appreciate your help.

Thanks in advance,


Midori

[Kenneth Hobs]

Do you know what ThisWorkbook object is? It is the workbook that the macro resides in. Check your spelling as you used ThisWorksbook".

If the tabname or sheetname in ThisWorkbook <> "Sheet1" then it will error if you try to set such. Note that the sheetname is not always the same as the codename.

So I added semi colon on the left side of the equation but still get the
same error message....

Why?

[midori323]

Do you know what ThisWorkbook object is? It is the workbook that the macro resides in. Check your spelling as you used ThisWorksbook".

If the tabname or sheetname in ThisWorkbook <> "Sheet1" then it will error if you try to set such. Note that the sheetname is not always the same as the codename.

Why?

[midori323]

Hi, Kenneth,

Sorry, the code I typed in my previous thread has typos.. There was
no "s" in my original VBA code.
I added semi colon as some trouble shooting tip suggested when I get
error end statement, semi colon or period is missing..

[Kenneth Hobs]

I don't use semicolons. Please paste your code.

As I said, if the sheetname/tabname does not exist, it will error. Here is an example to test for that.

Function Test_WorkSheetExists()  MsgBox "WorksheetExists? " & WorkSheetExists("Sheet1"), _
    vbInformation, "ActiveWorkbook.ActiveSheet"
    
   MsgBox "WorksheetExists? " & WorkSheetExists("ken", "ken.xlsm"), _
    vbInformation
    
  MsgBox "WorksheetExists? " & WorkSheetExists("Sheet1", ThisWorkbook.Name), _
    vbInformation
End Function


 'WorkSheetExists in a workbook:
Function WorkSheetExists(sWorkSheet As String, Optional sWorkbook As String = "") As Boolean
    Dim ws As Worksheet, wb As Workbook
    On Error GoTo notExists
    If sWorkbook = "" Then
      Set wb = ActiveWorkbook
      Else
      Set wb = Workbooks(sWorkbook) 'sWorkbook must be open already.  e.g. ken.xlsm, not x:\ken.xlsm.
    End If
    Set ws = wb.Worksheets(sWorkSheet)
    WorkSheetExists = True
    Exit Function
notExists:
    WorkSheetExists = False
End Function

[midori323]

Hi, Kenneth,

Thank you for your help again....but I don't think the missing sheet name or tabname is causing this error.
Because if I revert to my original code I uploaded in this forum,

Sub LoopThroughDirectory() 
    Dim MyFile As String 
    Dim erow 
    MyFile = Dir("C:\Users\ahozumi\Desktop\Business sheet\") 
    Do While Len(MyFile) > 0 
        If MyFile = "zmaster.xlsm" Then 
            Exit Sub 
        End If 
        Workbooks.Open (MyFile) 
        Range("A5,K27").Copy 
        ActiveWorkbook.Close 
        erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row 
        ActiveSheet.Paste Destination:=Worksheets("sheet1").Range(Cells(erow, 1), Cells(erow, 2)) 
        MyFile = Dir 
    Loop 
End Sub

And change the line 10, the definition of range to

Range.("J27:K27").Copy
This code worked to copy the cells from 6 workbook in "Business sheet" folder and paste on the area specified in
Active sheet....


But once I change the range specification to select 2 disperse cells in the worksheet, I encounter error message....

So I wonder Range cannot specify cells which are not contiguous...
I referred various guidance and tips and most examples used Range to specify cells which are contiguous....
But none of the reference said you cannot use Range to specify 2 or more disperse cells.

If I use Range, can't I specify two disperse cells like "A5" and "J27" like

Range("A5","J25").Copy

...?

[Kenneth Hobs]

When you copy like that, you MUST paste to the same number of rows and columns. While we can use Resize in the destination, the easier way is to paste to just one cell. e.g.

Worksheets(1).Range("A5", "J25").Copy Worksheets(2).Range("A1")

Of course you used a consecutive range just as if it was A5:J25.

If you want to use non-consecutive range(s), then more work is needed. e.g.

Sub Test()  
  'Worksheets(1).Range("A5", "J25").Copy Worksheets(2).Range("A1")
  
  'Worksheets(1).Range("A5,J25").Copy Worksheets(2).Range("A1") 'Errors, non-consective
  
  Dim a() As Variant
  a() = RangeTo1dArray(Worksheets(1).Range("A5,J25"))
  Worksheets(2).Range("A1").Resize(UBound(a) + 1).Value = WorksheetFunction.Transpose(a)
End Sub




Sub Test_RangeTo1dArray()
  Dim v As Variant, a() As Variant
  a() = RangeTo1dArray(ActiveSheet.UsedRange)


  For Each v In a()
    Debug.Print v
  Next
End Sub


Function RangeTo1dArray(aRange As Range) As Variant
  Dim a() As Variant, c As Range, i As Long
  ReDim a(0 To aRange.Cells.Count - 1)
  i = i - 1
  For Each c In aRange
    i = i + 1
    a(i) = c
  Next c
  RangeTo1dArray = a()
End Function