VBA code giving errors and stopping Excel

S

steve400243

Active Member
Joined
Sep 15, 2016
Messages
429
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Sort by date Sort by votes
Hi Steve

What line do you get an error on?

It may also help if you can explain what you're trying to achieve overall. There may be a simpler way to do what you need.

Caleeco
 
Upvote 0
It does not give an error on the code. My excel just locks up and then has to be reset. It also seems to take a long time to run. Overall this opens every file in the in the file path, and copies specific data from each file and builds a report. Separated by the header that I have in another sheet "Param". kind of hard to explain, but below is the desired results.
MBL - DEVANNED is from cells "C3", "C4", "C5", "H2", "H3", "H4" in the files that are opened
and the other data is from the other ranges noted in the code. Thanks for looking at it.


MBLVESSELCONTAINERRELEASEDRECEIVEDDEVANNEDHAWBCUSTOMS OBLDELIVERY ORDERSHIPPEDMODE
CMDUCNCT427114CMA CGM CALLISTOTGHU89031552/3/20202/3/20202/3/2020SHS0002099432/6/2020TELEX1/31/20202/6/2020FMM
SHS0002100691/21/2020TELEX1/24/20202/4/2020FMM
SHS0002102681/30/20202/7/20201/30/20202/7/2020FMM
SHS0002103852/3/20202/3/20202/3/20202/4/2020FMM
SHS0002103882/7/2020TELEX2/6/20202/7/2020
SHS0002104152/5/2020TELEX1/23/20202/5/2020FMM
SHS0002105182/3/20202/3/20202/3/20202/4/2020FMM
SHS0002105641/31/2020TELEX1/31/20202/4/2020FMM
SHS0002105862/3/20202/3/20202/3/20202/4/2020FMM
SHS0002105881/24/20201/24/20201/24/20202/4/2020FMM
SHS0002105931/28/2020TELEX1/29/20202/4/2020FMM
SHS0002102142/4/2020TELEX1/21/20202/4/2020FMM
SHS0002103101/29/2020TELEX1/23/20202/4/2020FMM
SHS0002105821/31/2020EXPRESS1/31/20202/4/2020FMM
 
Upvote 0
Here a macro with some improvements for you to consider.
With this code, the LastRow function is no longer necessary.

Note: Sheet1 must have at least one row with data in column B.

VBA 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
  Application.DisplayAlerts = 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 = sh.Range("B:M").Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1
      ThisWorkbook.Sheets("Param").Range("B1:M3").Copy sh.Cells(rw, 2)
      
      'Data 1
      rw = sh.Range("B:M").Find("*", , xlValues, , xlByRows, xlPrevious).Row + 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, G13:G35, H13:H35, J13:J35, K13:K35, D13:D35").Copy
        sh.Cells(rw, 8).PasteSpecial xlPasteValues
      End With
      
      wb.Close False
    End If
    fName = Dir
  Loop
  
  Application.StatusBar = False
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
Thank for that Dante, seems to work faster, but now i'm getting an "Automation Error Exception Occurred" In msft visual basic for applications in the middle of it running and it locks up excel.
 
Upvote 0
The process copied some books?

I guess you have problems with one of the books.
Try the following.
First, put the macro and the "Sheet1" and "param" sheets in a new book.
Try the following macro, which will save the book every time a file is processed, that way you can check which book has problems opening.

Rich (BB 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
  Application.DisplayAlerts = 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 = sh.Range("B:M").Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1
      ThisWorkbook.Sheets("Param").Range("B1:M3").Copy sh.Cells(rw, 2)
      
      'Data 1
      rw = sh.Range("B:M").Find("*", , xlValues, , xlByRows, xlPrevious).Row + 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, G13:G35, H13:H35, J13:J35, K13:K35, D13:D35").Copy
        sh.Cells(rw, 8).PasteSpecial xlPasteValues
      End With
      
      wb.Close False

      ThisWorkbook.Save

    End If
    fName = Dir
  Loop
  
  Application.StatusBar = False
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
With that setup i didn't get the Automation error, but "Excel has stopped working" is the new issue.
 
Upvote 0
Ok, you can check the last saved excel and analyze which was the last book copied, that way you will know if any of the books pending copying has the problem.
Or start discarding, remove the books that were copied from the folder and run the macro again, until you find which or which books at the time of opening are stopping to excel.
 
Upvote 0
Thank you very much for the Tips, I will do that next. I appreciate your time. and the improved code.
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Solved
Set value for range being copied over with VBA
2
Replies
14
Views
731
ItalianPlatinum
I
J
  • Solved
Speeding up VBA
Replies
9
Views
272
jvoss
J
Q
  • Solved
How to stop InputBox from looping after input?
Replies
7
Views
481
qplsn9
Q
M
  • Solved
cope method of worksheet class failed error - working code suddenly stopped working...
2
Replies
10
Views
624
dmt32
D
C
  • Question Question
Is there a way to do something similar in Office scripts/Powerautomate
Replies
2
Views
1K
Dan_W
D

Forum statistics

Threads
1,224,826
Messages
6,181,192
Members
453,021
Latest member
pingpong7117

Share this page

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
Back
Top