Run-time error '1004': Method 'Activate' of object '_Workbook' failed only on new PC

dougmarkham

Board Regular
Hi Folks,

I have an old excel model last modified in 2010 that was written by a pretty decent VBA / SQL programmer who has since deceased.

All our old machines are running Windows 7 professional on a 64 bit OS using 32 bit Excel 2013 (8 gb RAM).
A new PC installed recently runs Windows 7 professional on a 64 bit OS using 32 bit Excel 2013 (16 gb RAM).

When this old excel model attempts to import data from a *.xlsx file on the new PC, the following error message is generated: Run-time error '1004': Method 'Activate' of object '_Workbook'. The model has no issues importing data from a *xls file (97-2003).


Here is the Module of Code (line that fails is larger font in Red)

Code:
Option Explicit
Option Private Module


Public Function GetImportWorkbookPath() As Variant


'// Get File Path Using A Pre-Built Dialog
[SIZE=3][COLOR=#b22222][B]    GetImportWorkbookPath = Application.GetOpenFilename(FileFilter:="Excel Files,*.xls*", Title:="Please Select Import File", MultiSelect:=True)[/B][/COLOR][/SIZE]
End Function


Public Function ValidateImportFilePath(FilePath As String) As Boolean


'// Assume Valid Until Proved Otherwise
    ValidateImportFilePath = True


'// Validate
    If LCase(FilePath) = "false" Or IsEmpty(FilePath) Then
        ValidateImportFilePath = False
    End If
    
End Function


Public Sub ObtainImportData(importFile As Workbook)
Dim impData As Variant
Dim impSheet As Worksheet


'// Obtain Data From Import File
    importFile.Activate
    Set impSheet = importFile.Sheets(1)
    impSheet.Activate
    If ImportHasExtraRows = True Then
        impSheet.Range("5:6").EntireRow.Delete
        impSheet.Range("1:3").EntireRow.Delete
    End If
    FindLastRow impSheet
    FindLastColumn impSheet
    impData = impSheet.Range(Cells(1, 1), Cells(LastRow, LastCol))


'// Deposit Data Into 'ImportSheet'
    EventCalc.Activate
    With shtImportData
        .visible = xlSheetVisible
        .Activate
        .Range(Cells(1, 1), Cells(LastRow, LastCol)).value = impData
    End With
    
'// Close ImportFile?
    importFile.Close False


End Sub


Public Sub ObtainImportDataMultipleWB(importFile As Workbook, FirstWB As Boolean)
Dim ImportData As Variant
Dim AllocData As Variant
Dim ImportSheet As Worksheet
Dim currentStoreList As Variant
Dim errmsg As String
Dim x As Long, y As Long


'// Obtain Data From Import File
    importFile.Activate
    Set ImportSheet = importFile.Sheets(1)
    ImportSheet.Activate
    If ImportHasExtraRows = True Then
        ImportSheet.Range("5:6").EntireRow.Delete
        ImportSheet.Range("1:3").EntireRow.Delete
    End If
    FindLastRow ImportSheet
    FindLastColumn ImportSheet
    ImportData = ImportSheet.Range(Cells(1, 1), Cells(LastRow, LastCol))
    
'// Determine If Is First Import - If so deposit data, if not perform checks and append data!
    If FirstWB = True Then
    
        '// Deposit Data
        EventCalc.Activate
        With shtImportData
            .visible = xlSheetVisible
            .Activate
            .Range(Cells(1, 1), Cells(LastRow, LastCol)).value = ImportData
        End With
            
    Else
    
        '// Obtain List of Stores To Check Against
        EventCalc.Activate
        FindLastRow shtImportData
        currentStoreList = shtImportData.Range(Cells(1, 1), Cells(LastRow, 1))
    
        '// Perform Check - On Mismatch Exit.
        If UBound(currentStoreList, 1) <> UBound(ImportData, 1) Then
            errmsg = "Count of Stores in " & importFile.Name & vbCrLf & "Doesn't Equal Count of Stores In Previous Imported Files - Please Check!"
            CriticalErrorFailure errmsg
            RestoreTemplate
            End
        End If
        
        For x = ImportData_StartAllocationRow To UBound(currentStoreList, 1)
        
            If currentStoreList(x, 1) <> ImportData(x, 1) Then
                errmsg = "Store: " & currentStoreList(x, 1) & " <> " & ImportData(x, 1) & vbCrLf & "Whilst Attempting To Import: " & importFile.Name
                CriticalErrorFailure errmsg
                RestoreTemplate
                End
            End If
        
        Next x
        
        '// If Stores Match Entirely Copy Only Allocation Data Across (Store Data Not Required)
        FindLastRow shtImportData
        FindLastColumn shtImportData
        
        ReDim AllocData(1 To UBound(ImportData, 1), 1 To UBound(ImportData, 2) - (ImportData_StartProductsColumn - 1))
        
        For x = 1 To UBound(ImportData, 1)
        
            For y = ImportData_StartProductsColumn To UBound(ImportData, 2)
        
                AllocData(x, (y - ImportData_StartProductsColumn) + 1) = ImportData(x, y)
                
            Next y
            
        Next x
        
        shtImportData.Range(Cells(1, LastCol + 1), Cells(LastRow, (LastCol) + UBound(AllocData, 2))) = AllocData
        
        
    End If


'// Remove Any Spare 'Empty' Columns...
    FindLastColumn shtImportData
    For x = LastCol To 1 Step -1
    
        shtImportData.Activate
        If Application.WorksheetFunction.CountA(Cells(1, x).Address & ":" & Cells(MaxRowsExcel2003, x).Address) = 0 Then
            shtImportData.Columns(x).Delete
        End If
    
    Next x




'// Close Import File
    importFile.Close False


End Sub
Would anybody be willing to help me find out why this happens?

For instance,
1) Within this code, is there any VBA that is obsolete.
2) Why would an extra 8 gb of RAM effect an import (seems that the main spec difference is the RAM).

Has anybody had a similar thing happen to them??

Kind regards,

Doug.
 

steve the fish

Well-known Member
I cant see where you are using that function in any of that code nor can i see an activate in that line. Are you sure its that line?
 

dougmarkham

Board Regular
I cant see where you are using that function in any of that code nor can i see an activate in that line. Are you sure its that line?
Hi Steve the fish,

I ran the model again this morning to double check and found that the line was further down the same page of code:
Here is the culprit macro
Code:
Public Sub ObtainImportDataMultipleWB(importFile As Workbook, FirstWB As Boolean)
Dim ImportData As Variant
Dim AllocData As Variant
Dim ImportSheet As Worksheet
Dim currentStoreList As Variant
Dim errmsg As String
Dim x As Long, y As Long


'// Obtain Data From Import File
[SIZE=4][B][COLOR=#b22222]   importFile.Activate[/COLOR][/B][/SIZE]
    Set ImportSheet = importFile.Sheets(1)
    ImportSheet.Activate
    If ImportHasExtraRows = True Then
        ImportSheet.Range("5:6").EntireRow.Delete
        ImportSheet.Range("1:3").EntireRow.Delete
    End If
    FindLastRow ImportSheet
    FindLastColumn ImportSheet
    ImportData = ImportSheet.Range(Cells(1, 1), Cells(LastRow, LastCol))
    
'// Determine If Is First Import - If so deposit data, if not perform checks and append data!
    If FirstWB = True Then
    
        '// Deposit Data
        EventCalc.Activate
        With shtImportData
            .visible = xlSheetVisible
            .Activate
            .Range(Cells(1, 1), Cells(LastRow, LastCol)).value = ImportData
        End With
            
    Else
    
        '// Obtain List of Stores To Check Against
        EventCalc.Activate
        FindLastRow shtImportData
        currentStoreList = shtImportData.Range(Cells(1, 1), Cells(LastRow, 1))
    
        '// Perform Check - On Mismatch Exit.
        If UBound(currentStoreList, 1) <> UBound(ImportData, 1) Then
            errmsg = "Count of Stores in " & importFile.Name & vbCrLf & "Doesn't Equal Count of Stores In Previous Imported Files - Please Check!"
            CriticalErrorFailure errmsg
            RestoreTemplate
            End
        End If
        
        For x = ImportData_StartAllocationRow To UBound(currentStoreList, 1)
        
            If currentStoreList(x, 1) <> ImportData(x, 1) Then
                errmsg = "Store: " & currentStoreList(x, 1) & " <> " & ImportData(x, 1) & vbCrLf & "Whilst Attempting To Import: " & importFile.Name
                CriticalErrorFailure errmsg
                RestoreTemplate
                End
            End If
        
        Next x
        
        '// If Stores Match Entirely Copy Only Allocation Data Across (Store Data Not Required)
        FindLastRow shtImportData
        FindLastColumn shtImportData
        
        ReDim AllocData(1 To UBound(ImportData, 1), 1 To UBound(ImportData, 2) - (ImportData_StartProductsColumn - 1))
        
        For x = 1 To UBound(ImportData, 1)
        
            For y = ImportData_StartProductsColumn To UBound(ImportData, 2)
        
                AllocData(x, (y - ImportData_StartProductsColumn) + 1) = ImportData(x, y)
                
            Next y
            
        Next x
        
        shtImportData.Range(Cells(1, LastCol + 1), Cells(LastRow, (LastCol) + UBound(AllocData, 2))) = AllocData
        
        
    End If


'// Remove Any Spare 'Empty' Columns...
    FindLastColumn shtImportData
    For x = LastCol To 1 Step -1
    
        shtImportData.Activate
        If Application.WorksheetFunction.CountA(Cells(1, x).Address & ":" & Cells(MaxRowsExcel2003, x).Address) = 0 Then
            shtImportData.Columns(x).Delete
        End If
    
    Next x




'// Close Import File
    importFile.Close False


End Sub
That lies within this module (called ImportWorkbook):

Code:
Option Explicit
Option Private Module


Public Function GetImportWorkbookPath() As Variant


'// Get File Path Using A Pre-Built Dialog
[SIZE=2]    GetImportWorkbookPath = Application.GetOpenFilename(FileFilter:="Excel Files,*.xls*", Title:="Please Select Import File", MultiSelect:=True)[/SIZE]
End Function


Public Function ValidateImportFilePath(FilePath As String) As Boolean


'// Assume Valid Until Proved Otherwise
    ValidateImportFilePath = True


'// Validate
    If LCase(FilePath) = "false" Or IsEmpty(FilePath) Then
        ValidateImportFilePath = False
    End If
    
End Function


Public Sub ObtainImportData(importFile As Workbook)
Dim impData As Variant
Dim impSheet As Worksheet


'// Obtain Data From Import File
    importFile.Activate
    Set impSheet = importFile.Sheets(1)
    impSheet.Activate
    If ImportHasExtraRows = True Then
        impSheet.Range("5:6").EntireRow.Delete
        impSheet.Range("1:3").EntireRow.Delete
    End If
    FindLastRow impSheet
    FindLastColumn impSheet
    impData = impSheet.Range(Cells(1, 1), Cells(LastRow, LastCol))


'// Deposit Data Into 'ImportSheet'
    EventCalc.Activate
    With shtImportData
        .visible = xlSheetVisible
        .Activate
        .Range(Cells(1, 1), Cells(LastRow, LastCol)).value = impData
    End With
    
'// Close ImportFile?
    importFile.Close False


End Sub


Public Sub ObtainImportDataMultipleWB(importFile As Workbook, FirstWB As Boolean)
Dim ImportData As Variant
Dim AllocData As Variant
Dim ImportSheet As Worksheet
Dim currentStoreList As Variant
Dim errmsg As String
Dim x As Long, y As Long


'// Obtain Data From Import File
 [SIZE=4][COLOR=#b22222][B]   importFile.Activate[/B][/COLOR][/SIZE]
    Set ImportSheet = importFile.Sheets(1)
    ImportSheet.Activate
    If ImportHasExtraRows = True Then
        ImportSheet.Range("5:6").EntireRow.Delete
        ImportSheet.Range("1:3").EntireRow.Delete
    End If
    FindLastRow ImportSheet
    FindLastColumn ImportSheet
    ImportData = ImportSheet.Range(Cells(1, 1), Cells(LastRow, LastCol))
    
'// Determine If Is First Import - If so deposit data, if not perform checks and append data!
    If FirstWB = True Then
    
        '// Deposit Data
        EventCalc.Activate
        With shtImportData
            .visible = xlSheetVisible
            .Activate
            .Range(Cells(1, 1), Cells(LastRow, LastCol)).value = ImportData
        End With
            
    Else
    
        '// Obtain List of Stores To Check Against
        EventCalc.Activate
        FindLastRow shtImportData
        currentStoreList = shtImportData.Range(Cells(1, 1), Cells(LastRow, 1))
    
        '// Perform Check - On Mismatch Exit.
        If UBound(currentStoreList, 1) <> UBound(ImportData, 1) Then
            errmsg = "Count of Stores in " & importFile.Name & vbCrLf & "Doesn't Equal Count of Stores In Previous Imported Files - Please Check!"
            CriticalErrorFailure errmsg
            RestoreTemplate
            End
        End If
        
        For x = ImportData_StartAllocationRow To UBound(currentStoreList, 1)
        
            If currentStoreList(x, 1) <> ImportData(x, 1) Then
                errmsg = "Store: " & currentStoreList(x, 1) & " <> " & ImportData(x, 1) & vbCrLf & "Whilst Attempting To Import: " & importFile.Name
                CriticalErrorFailure errmsg
                RestoreTemplate
                End
            End If
        
        Next x
        
        '// If Stores Match Entirely Copy Only Allocation Data Across (Store Data Not Required)
        FindLastRow shtImportData
        FindLastColumn shtImportData
        
        ReDim AllocData(1 To UBound(ImportData, 1), 1 To UBound(ImportData, 2) - (ImportData_StartProductsColumn - 1))
        
        For x = 1 To UBound(ImportData, 1)
        
            For y = ImportData_StartProductsColumn To UBound(ImportData, 2)
        
                AllocData(x, (y - ImportData_StartProductsColumn) + 1) = ImportData(x, y)
                
            Next y
            
        Next x
        
        shtImportData.Range(Cells(1, LastCol + 1), Cells(LastRow, (LastCol) + UBound(AllocData, 2))) = AllocData
        
        
    End If


'// Remove Any Spare 'Empty' Columns...
    FindLastColumn shtImportData
    For x = LastCol To 1 Step -1
    
        shtImportData.Activate
        If Application.WorksheetFunction.CountA(Cells(1, x).Address & ":" & Cells(MaxRowsExcel2003, x).Address) = 0 Then
            shtImportData.Columns(x).Delete
        End If
    
    Next x




'// Close Import File
    importFile.Close False


End Sub
Kind regards,

Doug.
 

dougmarkham

Board Regular
How are you running that sub to give importfile its value? Nowhere within that code do you run that sub.
Hi Steve the fish,

Just got back from my vacation. The IT dept who own the model emailed me to let me know that they do not wish it altered (it's beyond my level, and it's beyond their capacity to understand also).
So instead, this morning, I built a model to allow a user to select a folder and convert it's *.xlsx files to *.xls files and vice versa.

I did have a look for code that runs the sub and couldn't find it, but I was also discouraged from further action.

Thanks anyway for the time, much appreciated!

Kind regards,

Doug.
 

Some videos you may like

This Week's Hot Topics

  • Importing multiple excel files into one spreadsheet
    Hi, I'm trying to import multiple excel files (with the same format into a single spreadsheet) so that each day's file is listed underneath the...
  • find many based on a certain criteria
    good evening, I hope someone can help me? I have a workbook sheet 2 contains lots of data.... I would like to be able to find anything on sheet...
  • How to copy multiple rows using If
    Hi all, I'm very new to VBA and have written this simple code to copy certain cells if a certain cell within that row contains any data. I need...
  • VBA If statement
    Dear All, I have two dates, where I'd like a message box to pop, if the dates are between this criteria. [CODE] sDate1 = #10/1/2019#...
  • Text Format
    I have a sheet for user to keyin the data. The format of the data can be 451 / 1903, 0012 / 9908 or 00287 / 0099. The number after the "/" is...
  • Syntax errors
    Good Morning, Trying to compile a workbook, I keep getting a few errors. Here are the first two: [code=rich]Syntax Error: Function...
Top