I should also mention that the Procedure passing the variables to the above procedure uses a new instance of the xl Application object to open the workbook.
You know what, here's the main procedure:
Option Explicit
Option Compare Text
Public Const strSheetName As String = "ACTIVE"
Public Const strSchedulingDir As String = "MyServer"
Public Const strFileStandard As String = "ProductionC"
Public Sub ImportDataMain()
'\\ Author: [redacted]
'\\ Date Created: December 14, 2006
'\\ Purpose: To automate daily reports about what has shipped and what
'\\ has not shipped for the current month.
' This main procedure is the setup for the actual importing of data from the
' scheduling workbook.
Dim xlApp As New Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSh As Excel.Worksheet
Dim xlDataRange As Excel.Range
Dim strWB As String
Dim curMonth As String
curMonth = MonthName(Month(Now()), False)
strWB = GetCurrentSchedule
If strWB = "" Then
' Error Occurred
MsgBox "The Scheduling File cannot be found." & vbCrLf & "The procedure cannot continue.", _
vbCritical, "Error Occurred"
GoTo ErrorHandler
End If
' Open the workbook behind the scenes. This will not bring up an error even if
' the workbook is already open because you are creating a whole new instance of the Application object
Set xlWB = xlApp.Workbooks.Open(strSchedulingDir & strWB, ReadOnly:=True)
If SheetExists(xlWB, strSheetName) = False Then
' Error Occurred
MsgBox "The sheet " & strSheetName & " does not exists." & vbCrLf & "The procedure cannot continue.", _
vbCritical, "Error Occurred"
GoTo ErrorHandler
Else
Set xlSh = xlWB.Worksheets(strSheetName)
End If
If IsError(GetDataRange(curMonth, xlWB, xlSh)) Then
' Error Occurred
MsgBox "There has been an error in finding the data range." & vbCrLf & "The procedure cannot continue.", _
vbCritical, "Error Occurred"
GoTo ErrorHandler
End If
' Get the data range for the importing process
Set xlDataRange = GetDataRange(curMonth, xlWB, xlSh)
' Now that everything necessary has been collected, start the importing process
Call ImportDataNow(xlWB, xlSh, xlDataRange)
ErrorHandler:
xlWB.Close
xlApp.Quit
End Sub
And here's the function to get the data range (for the guru's, please don't laugh / ask. I'm working with a retarted worksheet for the moment which I'm trying to convince everyone we should consider a new design. I just need these procedures as a quick workaround.)
Public Function GetDataRange(ByVal strMonth As String, ByVal xlWB As Excel.Workbook, _
ByVal xlSh As Excel.Worksheet) As Variant
' Returns the specified range for the Scheduling workbook based on month
' First test if the strMonth is an actual month
On Error Resume Next
Dim lTest As Long
lTest = Month(DateValue("01-" & strMonth & "-1900"))
If Err.Number <> 0 Then
GetDataRange = CVErr(xlErrValue)
Exit Function
End If
On Error GoTo 0
Dim rngStart As Excel.Range, rngEnd As Excel.Range, rngFinal As Excel.Range
Dim i As Long, j As Long, iLastCol As Long
' Get the short month
strMonth = Application.WorksheetFunction.Proper(Left(strMonth, 3))
' Get Last column
iLastCol = xlWB.Worksheets(xlSh.Name).Cells(1, Columns.Count).End(xlToLeft).Column
' Find the range based on the Month passed to the function
With xlWB.Worksheets(xlSh.Name).Range("A1:A" & xlWB.Worksheets(xlSh.Name).Cells(Rows.Count, 1).End(xlUp).Row)
Set rngStart = .Cells.Find(What:=strMonth, LookIN:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False)
End With
' Could not find range
If rngStart Is Nothing Then
GetDataRange = CVErr(xlErrValue)
Exit Function
End If
' Since findind the first instance of the strMonth string, we're going to move down cells
' until there is no blank.
Do
i = i + 1
Set rngStart = rngStart.Offset(1, 0)
' There needs to be some kind of control incase the found cell is the last in the used range
If i = 20 Then ' Too many blank cells
GetDataRange = CVErr(xlErrValue)
Exit Function
End If
Loop Until rngStart.Value <> ""
' Now find the last row used in the range...this is tricky because there are blank rows
' in the scheduling workbook. So we'll use Column D because after the last cell used
' there are many blank rows together.
i = 0
Set rngEnd = xlWB.Worksheets(xlSh.Name).Cells(rngStart.Row, "D")
Do
i = i + 1
If rngEnd.Offset(i, 0).Value <> "" Then
' If it makes it here, reset the rngEnd
Set rngEnd = rngEnd.End(xlDown)
i = 0
End If
Loop Until i = 4
' Set rngEnd to be the last row of usable data and last column & to include the headers
Set rngEnd = xlWB.Worksheets(xlSh.Name).Cells(rngEnd.Row, iLastCol)
' Get final range (including the headers)
Set rngFinal = xlWB.Worksheets(xlSh.Name).Range("A1:" & xlWB.Worksheets(xlSh.Name).Cells(2, rngEnd.Column).Address & _
", " & rngStart.Address & ":" & rngEnd.Address)
' Have to use Set keyword to create the range object passed back to the calling procedure
Set GetDataRange = rngFinal
'Debug.Print rngStart.Address(0, 0), rngEnd.Address(0, 0)
End Function
Then I tried this and it works when I have the workbook open in the same instance:
Sub TestMe()
Workbooks("ProductionC121506.xls").Sheets("ACTIVE").Range("A1:AG2,A3329:AG3575").Copy _
Destination:=Workbooks("Book1").Sheets("Scheduling Import - December").Range("A1")
End Sub
So I *think* my problem lies from copying and pasting across Application instances, but I could be wrong.
I don't know what else to say...
Reply With Quote
Why? What would you have done?
