VBA code giving errors and stopping Excel

steve400243

Active Member
Joined
Sep 15, 2016
Messages
292
Hello Experts, I have this code being used to loop through files in a file path, and copy specific data to another sheet. It is giving me several problems when trying to run it. Was hoping someone could look at it and see any errors or suggestions they may have to make it run better? thanks for any help provided.

Code:
Sub t()
   Dim wb As Workbook, sh As Worksheet, ary As Variant, fPath As String, fName As String, i As Long, rw As Long
  
   Application.ScreenUpdating = False
  
   fPath = "X:\SEA Shares\warehouse\CFS and FMM Program\SEA Devanned February-2020\"

   Set sh = ThisWorkbook.Sheets("Sheet1")
   ary = Array("C3", "C4", "C5", "H2", "H3", "H4")
  
   fName = Dir(fPath & "*.xls*")
   Do While fName <> ""
      Application.StatusBar = "Please be patient... processing: " & fName
      If fName <> ThisWorkbook.Name Then
      
         Set wb = Workbooks.Open(fPath & fName)
        
         'Header (Optional)
         rw = LastRow(sh.Range("B60000:M60000")) + 1
         ThisWorkbook.Sheets("Param").Range("B1:M3").Copy sh.Cells(rw, 2)
        
         'Data 1
         rw = LastRow(sh.Range("B60000:M60000")) + 1
         For i = 2 To 7
            sh.Cells(rw, i) = wb.Sheets(1).Range(ary(i - 2)).Value
         Next i
        
         'Data 2 (Paste Values only)
         With wb.Sheets(1)
            .Range("A13:A35").Copy
            sh.Cells(rw, 8).PasteSpecial xlPasteValues

            .Range("G13:G35").Copy
            sh.Cells(rw, 9).PasteSpecial xlPasteValues

            .Range("H13:H35").Copy
            sh.Cells(rw, 10).PasteSpecial xlPasteValues

            .Range("J13:J35").Copy
            sh.Cells(rw, 11).PasteSpecial xlPasteValues

            .Range("K13:K35").Copy
            sh.Cells(rw, 12).PasteSpecial xlPasteValues
            
            .Range("D13:D35").Copy
            sh.Cells(rw, 13).PasteSpecial xlPasteValues
         End With
        
         wb.Close False
      End If
      fName = Dir
   Loop
  
   Application.StatusBar = False
   Application.ScreenUpdating = True
End Sub

'Find last row when looking at multiple columns. Return 99999 = error.
Function LastRow(rg As Range) As Long
   Dim c As Range
   If rg.Cells.Count > 100 Then LastRow = 99999: Exit Function
   LastRow = 0
   For Each c In rg
      If c.End(xlUp).Row > LastRow Then
         LastRow = c.End(xlUp).Row
      End If
   Next c
End Function
 

Some videos you may like

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.

steve400243

Active Member
Joined
Sep 15, 2016
Messages
292
Still going back to the errors, going to do some mock up test files to try it out with. I will post back on here with any more questions. Thanks again.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
Still going back to the errors, going to do some mock up test files to try it out with. I will post back on here with any more questions. Thanks again.
Surely some of your books have problems.
Some of the books have hidden or very hidden sheets.
Merged cells.
Protective sheets
Protected book
Have you identified which book has problems? Something in particular from that book different from the other books that do work?
 

steve400243

Active Member
Joined
Sep 15, 2016
Messages
292

ADVERTISEMENT

So I did up 4 test new files, and the code runs, but still getting the errors, but 0ne of the files data posts as it should?
MBLVESSELCONTAINERRELEASEDRECEIVEDDEVANNEDHAWBCUSTOMS OBLDELIVERY ORDERSHIPPEDMODE
testtesttesttesttesttesttesttesttesttesttesttest
testtesttesttesttesttest
testtesttesttesttesttest
testtesttesttesttesttest
testtesttesttesttesttest
 

steve400243

Active Member
Joined
Sep 15, 2016
Messages
292
Do you think I am going about this the correct way? - Here is the run down. We have several files in Monthly folders SEA January-2020, SEA February-2020, etc. all of the files are formatted the same. I need each file to open, copy the needed data, and create the report like the screen shot in the last post. Then the header row copying on the next row down and the next files data listing out. and so on entil all the files in the folder are listed on the report. The rows for the data below would vary per file, but it would never go over row 35. Thanks for any ideas you may have.
CUSTOMSOBLDELIVERY ORDERSHIPPEDMODE

row data
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

I need each file to open, copy the needed data

That makes the macro, I have no problems with my tests and with my test files.

What version of Excel do you have?

Maybe if you can upload your test files to the cloud, I check what the problem is.

You could upload a copy of your file to a free site such www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
Change this line

Set wb = Workbooks.Open(fPath & fName)

For this, and try again.

Set wb = Workbooks.Open(fPath & fName, False, True)
 

Watch MrExcel Video

Forum statistics

Threads
1,123,380
Messages
5,601,297
Members
414,440
Latest member
Kim0204

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top