Encountering VB code error when running merge excel files over a work network

[Jamel]

Last year I stumbled across this code I've been using since. Last year I didn't run into any issues, but this year all of a sudden I'm running into issues that I've limited the cause to involving my work network drives. I say this because when I point the macro below to a local drive it works every time. I think the issue centers around others staff being in the file and the macro being able to handle opening the file in read only format. Normal the macro successfully opens the file. However there has been instances when the excel files become locked due to the network, and it shows a staff person being in the file when it is not the case. What I was hoping was if someone could show me where I could include some code that would prevent the macro from bombing out due network instability. Network instability that cause a file remaining to be lock which causes the macro to bomb out I haven't been able to resolve with our network administer. His only remedy has be to click notify and wait patiently until the file becomes available again. Even when I do that something remains suspended with the file which has result in me copying the file to another location and pointing the macro to another spot on my work network.

Sub simpleXlsMerger()
Dim bookList As Workbook


Dim a, SC As Integer


Dim mergeObj, dirObj, filesObj, everyObj As Object


Application.AskToUpdateLinks = False
Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")

'/ This section is where I indicate the path on the network in which I wish to capture files.
sFilePath = ThisWorkbook.Worksheets(1).Range("B23").Text
Set dirObj = mergeObj.Getfolder(sFilePath)


Set filesObj = dirObj.Files
For Each everyObj In filesObj
Application.EnableEvents = False


Set bookList = Workbooks.Open(everyObj)


bookList.Worksheets(1).Activate


Range("A2:CG" & Range("A65536").End(xlUp).Row).Copy


ThisWorkbook.Worksheets("Allstaff").Activate


Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False




bookList.Close savechanges:=False
Next

 

[dmt32]

Hi,
see if this code does what you want:

Sub MergeData()


    Dim FileName As String, FilePath As String
    Dim LR As Long
    Dim PasteRange As Range
    Dim wbSource As Workbook, wsAllStaff As Worksheet
    
    On Error GoTo myerror
    
    Set wsAllStaff = ThisWorkbook.Worksheets("AllStaff")
    
    FilePath = ThisWorkbook.Worksheets(1).Range("B23").Text
    If Len(FilePath) = 0 Then Exit Sub
    
    If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
    
    If Not Dir(FilePath, vbDirectory) = vbNullString Then
       
        FileName = Dir(FilePath & "*.xls*")
        
        EventsEnable False
        
        'Import a sheet from found files
        Do While Len(FileName) > 0
            
            If FileName <> ThisWorkbook.Name Then
                
                Set wbSource = Workbooks.Open(FilePath & FileName, ReadOnly:=True)
                
                With wbSource
                LR = .Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
                
                    .Sheets(1).Range("A2:CG" & LR).Copy
                    
                    Set PasteRange = wsAllStaff.Range("A" & wsAllStaff.Rows.Count).End(xlUp).Offset(1)
                    
                    PasteRange.PasteSpecial xlPasteValues
                
                .Close False
                End With
            
            End If
            
            FileName = Dir
            Set wbSource = Nothing
            Set PasteRange = Nothing
            Application.CutCopyMode = False
        Loop
        
    Else
    
    MsgBox FilePath & Chr(10) & "File Path Not Found", 16, "Not Found"
    
    End If
    


myerror:
If Not wbSource Is Nothing Then wbSource.Close False
EventsEnable True
If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub


Sub EventsEnable(ByVal State As Boolean)
    With Application
        .ScreenUpdating = State
        .EnableEvents = State
        .DisplayAlerts = State
    End With
End Sub

Dave

 

[Jamel]

I luv you man!

May I ask another question. I would like for the paste to skip rows that contain blanks. does this account for this?
Also I added some macros I recorded in the beginning of the statements to delete all data before importing in anything
and resetting the last active cell so that the last active cell is reestablish after the most recent import. The problem Im running into is
its not resetting the last active cell. So if my import decreases, its maintaining the previous active cell. How can I get this to work properly. Here's my code as it looks currently.

Sub MergeData()


Call DeleteAllbutHeadings
Range("A2").Select
Call ResetRange
Dim FileName As String, FilePath As String
Dim LR As Long
Dim PasteRange As Range
Dim wbSource As Workbook, wsAllStaff As Worksheet

On Error GoTo myerror

Set wsAllStaff = ThisWorkbook.Worksheets("AllStaff")

FilePath = ThisWorkbook.Worksheets(1).Range("B23").Text
If Len(FilePath) = 0 Then Exit Sub

If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"

If Not Dir(FilePath, vbDirectory) = vbNullString Then

FileName = Dir(FilePath & "*.xls*")

EventsEnable False

'Import a sheet from found files
Do While Len(FileName) > 0

If FileName <> ThisWorkbook.Name Then

Set wbSource = Workbooks.Open(FilePath & FileName, ReadOnly:=True)

With wbSource
LR = .Sheets(1).Range("A" & Rows.Count).End(xlUp).Row

.Sheets(1).Range("A2:CG" & LR).Copy

Set PasteRange = wsAllStaff.Range("A" & wsAllStaff.Rows.Count).End(xlUp).Offset(1)

PasteRange.PasteSpecial xlPasteValues

.Close False
End With

End If

FileName = Dir
Set wbSource = Nothing
Set PasteRange = Nothing
Application.CutCopyMode = False
Loop

'These calls below Copies formula from row2 to last active cell

Call FTETextFormula
Call VlookupBUFormula
Call VlookupRatePtsFormula
Call VlookupRateEffFormula
Call VlookupTenureFormula
Call cmdRefreshAll
Else

MsgBox FilePath & Chr(10) & "File Path Not Found", 16, "Not Found"

End If





myerror:
If Not wbSource Is Nothing Then wbSource.Close False
EventsEnable True
If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub




Sub EventsEnable(ByVal State As Boolean)
With Application
.ScreenUpdating = State
.EnableEvents = State
.DisplayAlerts = State
End With
End Sub

 

[Jamel]

Currently my ResetRange command of Application.Activesheet.UsedRange isn't working.

 

[dmt32]

Hi,
Not tested but updated code should filter blank rows before copying:

Sub MergeData()


    Dim FileName As String, FilePath As String
    Dim LR As Long
    Dim PasteRange As Range, CopyRange As Range
    Dim wbSource As Workbook, wsAllStaff As Worksheet
    
    On Error GoTo myerror
    
    Set wsAllStaff = ThisWorkbook.Worksheets("AllStaff")
    
    FilePath = ThisWorkbook.Worksheets(1).Range("B23").Text
    If Len(FilePath) = 0 Then Exit Sub
    
    If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
    
    'If Dir(FilePath, vbDirectory) = vbNullString Then Err.Raise 76, , FilePath
    
    If Not Dir(FilePath, vbDirectory) = vbNullString Then
       
        FileName = Dir(FilePath & "*.xls*")
        
        EventsEnable False
        
        'Import a sheet from found files
        Do While Len(FileName) > 0
            
            If FileName <> ThisWorkbook.Name Then
                
                Set wbSource = Workbooks.Open(FilePath & FileName, ReadOnly:=True)
                
                With wbSource
                LR = .Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
                    .Sheets(1).Range("A1:CG" & LR).AutoFilter Field:=1, Criteria1:="<>"
                    
                    Set CopyRange = .Sheets(1).AutoFilter.Range
                    
                    CopyRange.SpecialCells(xlCellTypeVisible).Copy
                    
                    Set PasteRange = wsAllStaff.Range("A" & wsAllStaff.Rows.Count).End(xlUp).Offset(1)
                    
                    PasteRange.PasteSpecial xlPasteValues
                
                    .Close False
                End With
            
            End If
            
            FileName = Dir
            Set wbSource = Nothing
            Set PasteRange = Nothing
            Set CopyRange = Nothing
            Application.CutCopyMode = False
        Loop
        
    Else
    
    MsgBox FilePath & Chr(10) & "File Path Not Found", 16, "Not Found"
    
    End If
    


myerror:
If Not wbSource Is Nothing Then wbSource.Close False
EventsEnable True
If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

I cannot offer any guidance with your supplementary question as you would need to post the code you are calling - however, probably better you start a new thread which should encourage some new responses.

Dave

 

[Jamel]

Can someone tell me what to include to the above code to get it to ignore if the source file as Autofilter turned on. For example,
one of the files Im merging the user has autofilter on to show only 36 or the 500 records. As a result of this, the code is only
merging 36 records of that file instead of all 500 records. Any help would be appreciated.

 

[Jamel]

this is my current code

Sub MergeData()


Call DeleteAllbutHeadings
Range("A2").Select
Call ResetRange
Dim FileName As String, FilePath As String
Dim LR As Long
Dim PasteRange As Range
Dim wbSource As Workbook, wsAllStaff As Worksheet

On Error GoTo myerror

Set wsAllStaff = ThisWorkbook.Worksheets("AllStaff")

FilePath = ThisWorkbook.Worksheets(1).Range("B23").Text
If Len(FilePath) = 0 Then Exit Sub

If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"

If Not Dir(FilePath, vbDirectory) = vbNullString Then

FileName = Dir(FilePath & "*.xls*")

EventsEnable False

'Import a sheet from found files
Do While Len(FileName) > 0

If FileName <> ThisWorkbook.Name Then

Set wbSource = Workbooks.Open(FilePath & FileName, ReadOnly:=True)

With wbSource
LR = .Sheets(1).Range("A" & Rows.Count).End(xlUp).Row

.Sheets(1).Range("A2:CG" & LR).Copy

Set PasteRange = wsAllStaff.Range("A" & wsAllStaff.Rows.Count).End(xlUp).Offset(1)

PasteRange.PasteSpecial xlPasteValues

.Close False
End With

End If

FileName = Dir
Set wbSource = Nothing
Set PasteRange = Nothing
Application.CutCopyMode = False
Loop

'These calls below Copies formula from row2 to last active cell

Call FTETextFormula
Call VlookupBUFormula
Call VlookupRatePtsFormula
Call VlookupRateEffFormula
Call VlookupTenureFormula
Call cmdRefreshAll
Else

MsgBox FilePath & Chr(10) & "File Path Not Found", 16, "Not Found"

End If





myerror:
If Not wbSource Is Nothing Then wbSource.Close False
EventsEnable True
If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub




Sub EventsEnable(ByVal State As Boolean)
With Application
.ScreenUpdating = State
.EnableEvents = State
.DisplayAlerts = State
End With
End Sub