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
 

steve400243

Active Member
Joined
Sep 15, 2016
Messages
292
Here is a code that does something similar, but I could not get it to function properly. It didn't seem to get the excel problems with it? It does not use the header page "Param"

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
   Dim SourceRow As Long
  
      
   fPath = ThisWorkbook.Path & "\" ' "X:\SEA Shares\warehouse\CFS and FMM Program\SEA Devanned February-2020\"
   Set sh = Sheets(1)
   ary = Array("C3", "C4", "C5", "H2", "H3", "H4")
   fName = Dir(fPath & "*.xls*")
    
    Do While fName <> ""
        If fName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(fPath & fName)
                rw = sh.Cells(Rows.Count, 2).End(xlUp)(2).Row
                For i = 2 To 7
                    sh.Cells(rw, i) = wb.Sheets(1).Range(ary(i - 2)).Value
                Next
                SourceRow = 13
                Do Until wb.Sheets(1).Cells(SourceRow, "A") = ""
                  
                  sh.Cells(rw, "H") = wb.Sheets(1).Cells(SourceRow, "A")
                  sh.Cells(rw, "I") = wb.Sheets(1).Cells(SourceRow, "G")
                  sh.Cells(rw, "J") = wb.Sheets(1).Cells(SourceRow, "H")
                  sh.Cells(rw, "K") = wb.Sheets(1).Cells(SourceRow, "J")
                  sh.Cells(rw, "L") = wb.Sheets(1).Cells(SourceRow, "K")
                  
                  SourceRow = SourceRow + 1
                  rw = rw + 1
                Loop

                
                wb.Close False
        End If
        fName = Dir
    Loop
    
End Sub
 

Some videos you may like

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

steve400243

Active Member
Joined
Sep 15, 2016
Messages
292
Thank you for your help Dante, I appreciate It. I got it working as needed with this code -

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
   Dim LastSourceRow As Long
   Dim SourceCount As Long
   Const FirstSourceRow = 13
  
    Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
   fPath = ThisWorkbook.Path & "\" ' "X:\SEA Shares\warehouse\CFS and FMM Program\SEA Devanned January-2020\"
   Set sh = Sheets(1)
   ary = Array("C3", "C4", "C5", "H2", "H3", "H4")
   fName = Dir(fPath & "*.xls*")
  
   rw = sh.Cells(Rows.Count, "H").End(xlUp).Row + 1
   Do While fName <> ""
      If fName <> ThisWorkbook.Name Then
      
         If rw > 3 Then
            sh.Rows(rw).Value = sh.Rows(2).Value
            rw = rw + 1
         End If
        
        
         Set wb = Workbooks.Open(fPath & fName)
         For i = 2 To 7
            sh.Cells(rw, i) = wb.Sheets(1).Range(ary(i - 2)).Value
         Next
        
         With wb.Sheets(1)
            LastSourceRow = .Cells(.Rows.Count, "A").End(xlUp).Row
         End With
         SourceCount = LastSourceRow - FirstSourceRow + 1
        
         sh.Range(sh.Cells(rw, "H"), sh.Cells(rw + SourceCount, "H")).Value = wb.Sheets(1).Range(wb.Sheets(1).Cells(FirstSourceRow, "A"), wb.Sheets(1).Cells(LastSourceRow, "A")).Value
         sh.Range(sh.Cells(rw, "I"), sh.Cells(rw + SourceCount, "I")).Value = wb.Sheets(1).Range(wb.Sheets(1).Cells(FirstSourceRow, "G"), wb.Sheets(1).Cells(LastSourceRow, "G")).Value
         sh.Range(sh.Cells(rw, "J"), sh.Cells(rw + SourceCount, "J")).Value = wb.Sheets(1).Range(wb.Sheets(1).Cells(FirstSourceRow, "H"), wb.Sheets(1).Cells(LastSourceRow, "H")).Value
         sh.Range(sh.Cells(rw, "K"), sh.Cells(rw + SourceCount, "K")).Value = wb.Sheets(1).Range(wb.Sheets(1).Cells(FirstSourceRow, "J"), wb.Sheets(1).Cells(LastSourceRow, "J")).Value
         sh.Range(sh.Cells(rw, "L"), sh.Cells(rw + SourceCount, "L")).Value = wb.Sheets(1).Range(wb.Sheets(1).Cells(FirstSourceRow, "K"), wb.Sheets(1).Cells(LastSourceRow, "K")).Value
        
         rw = rw + SourceCount
      
      
         wb.Close False
        
      End If
      
      fName = Dir
      
   Loop
    
End Sub
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to know that it already works for you. 🍻
 

steve400243

Active Member
Joined
Sep 15, 2016
Messages
292
One question I did have is if adding 1 empty row between each file's data? Would I do that here?

VBA Code:
rw = sh.Cells(Rows.Count, "H").End(xlUp).Row + 1
 

DanteAmor

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

ADVERTISEMENT

I think:

Rich (BB code):
         If rw > 3 Then
            rw = rw + 1
            sh.Rows(rw).Value = sh.Rows(2).Value
            rw = rw + 1
         End If
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
Again with pleasure. Thanks for the feedback
 

Watch MrExcel Video

Forum statistics

Threads
1,123,389
Messages
5,601,387
Members
414,448
Latest member
Jessica 22664

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