Interesting transferspreadsheet issue

R

Rat1sully

Unhappy Forced codemonkey
Local time
Today, 05:14
Joined
May 15, 2012
Messages
44
Ok this is a new one I've not seen anywhere and I'm wondering if any of you guys can offer some advice on what on earth is going on here.

Basically this process rips a load of data from a query and dumps it into a new sheet in a workbook.

and there in lies the problem, in order to get it to put things in tabs properly I've had to build strSheetName expression but when translated to a tab name instead of
Code: 
Something
I get
Code: 
"Something_
hence the bit under the transferspreadsheet that removes this

that all being well and good is quite slow and falls over if the strSheetName ends up containing brackets any ideas how to get this to work properly

Code: 
Private Sub cmdOSP_Click()
On Error GoTo Err_cmdOSP_Click
'GoTo Exit_cmdOSP_Click
Dim rs As Recordset
    Dim db As DAO.Database
    Dim varList As String
    Dim strSQL As String
    Dim qdf As DAO.QueryDef
    Dim strClassName As String
    Dim strSheetName As String
    Dim strSheetName1 As String
 
Set db = CurrentDb()
Set rs = db.OpenRecordset("Select Class From tblClass")
 
    Set qdf = db.QueryDefs("qryOSP")
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "qryOSP", CurrentProject.Path & "\Output\OSP_Analysis.xls", True, "OSP Analysis"
    Set qdf = Nothing
Do Until rs.EOF
 
    strClassName = ""
    strClassName = "'" & rs!Class & "'"
    strSQL = "SELECT [tblMEList].[Equipment Tag], [tblPlatformList].Vessel, tblClass.Class, [tblShipFitData].[Quantity fitted]" & _
            "FROM ([tblMEList] INNER JOIN [tblShipFitData] ON [tblMEList].[Equipment Tag] = [tblShipFitData].Equipment)INNER JOIN (tblClass INNER JOIN [tblPlatformList] ON tblClass.Class = [tblPlatformList].Class) ON [tblShipFitData].Vessel = [tblPlatformList].Vessel "
 
    strSQL = strSQL & "WHERE tblClass.Class IN (" & strClassName & ");"
 
    Set qdf = db.QueryDefs("qryClassOutput")
    qdf.SQL = strSQL
    strSheetName = ""
    strSheetName = Chr(34) & rs!Class & Chr(34)
    strSheetName1 = rs!Class
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "qryClassOutput", CurrentProject.Path & "\Output\OSP_Analysis.xls", True, strSheetName
    Debug.Print rs!Class
    Debug.Print strSheetName
    Set qdf = Nothing
    rs.MoveNext
 
    Dim XLApp As Object
    ' Open the XLS fle
    Set XLApp = CreateObject("Excel.Application")
    With XLApp
    'Keep working in the background for now
    .Application.Visible = False
    .UserControl = True
    'Open Workbook
    .Workbooks.Open CurrentProject.Path & "\Output\OSP_Analysis.xls"
    'Remove excess Charcters
    .Sheets(Chr(34) & strSheetName1 & "_").Name = strSheetName1
    .Application.DisplayAlerts = False
    .ActiveWorkbook.SaveAs CurrentProject.Path & "\Output\OSP_Analysis.xls"
    .Workbooks.Close
    .Quit
    .Application.Visible = True
    .Application.DisplayAlerts = True
    End With
    Set XLApp = Nothing
 
Loop
Set db = Nothing
Exit_cmdOSP_Click:
    MsgBox "This Feature is not enabled yet", vbOKOnly, "Error"
    Exit Sub
Err_cmdOSP_Click:
    MsgBox Err.Number & " " & Err.Description
    Resume Exit_cmdOSP_Click
End Sub
 
The problem is that you are using the CHR(34)'s on that. If rs!Class is a text field, you can assign it to the string without quotes. So use this instead:

Code: 
strSheeName = rs!Class
 
see I thought that and that's what i did to start with but they all end up coming out as tabs with just the first value and come the second iteration of the loop you get the subscript out of range error

edit: so I thought what the hell I might well have done something wrong and tried it without the chr(34)s in and it ran for 2/3 and then came up with a new error for me
Code: 
2046 The Command or action 'TransfereSpreadsheet' isn't available now.
so shall start looking into that if anyone wants to chip in on that please feel free
 
Last edited:
I just realized that your output should be overwriting the entire spreadsheet. You really only want transfer spreadsheet if you are doing it one time (at least that has been my experience). Otherwise you should use the Excel object model to do what you are trying to do.

A function that I have on my website is this one:
http://www.btabdevelopment.com/ts/tq2xlspecwspath

You'll need to add that code to a standard module and then add code to it to save and close the workbook and then you would just call that function in the loop with the changing sheet names.
 
Posted below is what I ended up with, it works and all the formatting comes out perfect but it's a slow process takes at least 15 mins on this delightful piece of modern computing I'm working on (read workstation circa 2004)

would your function be any quicker?

edit: have amended code to the latest load i'm running this only really includes a couple of replace() instances where i'd removed the IF statements

Code: 
Private Sub cmdOSP_Click()
On Error GoTo Err_cmdOSP_Click

Dim LResponse As Integer
    LResponse = MsgBox("Plese be aware that generating the OSP analysis can take in excess of 15 minutes on some computers, do you still wish to continue?", vbOKCancel, "Continue?")
    If LResponse = vbOK Then
    Else
        Exit Sub
    End If
 
Dim rs As Recordset
    Dim db As DAO.Database
    Dim varList As String
    Dim strSQL As String
    Dim qdf As DAO.QueryDef
    Dim strClassName As String
    Dim strSheetName As String
    Dim strSheetName1 As String
    Dim lngStartColumn As Long
    Dim rngColumn1 As Range
    Dim strPath As String
    Dim strPath1 As String
    
    
Set db = CurrentDb()
Set rs = db.OpenRecordset("Select Class From tblClass")
strPath = CurrentProject.Path & "\Output\OSP Analysis " & Format(Now(), "yyyymmdd_hhnn") & ".xls"
strPath1 = "OSP Analysis " & Format(Now(), "yyyymmdd_hhnn") & ".xls"
lngStartColumn = 9
    
    Set qdf = db.QueryDefs("qryOSP")
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "qryOSP", strPath, True, "OSP Analysis"
    Set qdf = Nothing
    
    Dim XLApp As Object
    Dim xlBook1 As Excel.Workbook
    Dim xlSheet1 As Excel.Worksheet
    ' Open the XLS fle
    Set XLApp = CreateObject("Excel.Application")
    XLApp.Workbooks.Open strPath
    Set xlBook1 = XLApp.Workbooks(strPath1)
    'xlBook.Open
    Set xlSheet1 = xlBook1.Worksheets(1)
With XLApp
    'Keep working in the background for now
    .Application.Visible = False
    .UserControl = True
    With xlSheet1
    'Change Row Height
    .Rows("1:1").RowHeight = 25.5
    'Set rows to wrap text
    .Rows("1:1").WrapText = True
    'Set Columns to auto width
    .Columns("A:H").EntireColumn.AutoFit
    'Insert new row at top
    .Rows("1:1").Insert
    
    'Borders
    With .Range("a2:h334").Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    
    Dim item As Variant, MyRange1 As Range, MyRange2 As Range, MyRange3 As Range
    Set MyRange1 = .Range("A2:D334")
    For item = 7 To 10
        With MyRange1.Borders(item)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
    Next
    
    Set MyRange2 = .Range("E2:H334")
    For item = 7 To 10
        With MyRange2.Borders(item)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
    Next
    
    Set MyRange3 = .Range("a2:H2")
    For item = 7 To 10
        With MyRange3.Borders(item)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
    Next
    End With
    
    'Save
    .Application.DisplayAlerts = False
    xlBook1.SaveAs strPath
    .Workbooks.Close
    .Application.Visible = True
    .Application.DisplayAlerts = True
    .Quit
End With
    Set XLApp = Nothing
'GoTo Exit_cmdOSP_Click
Do Until rs.EOF
    
    strClassName = ""
    strClassName = "'" & rs!Class & "'"
    strSQL = "SELECT [tblMEList].[Equipment Tag], [tblPlatformList].Vessel, tblClass.Class, [tblShipFitData].[Quantity fitted]" & _
            "FROM ([tblMEList] INNER JOIN [tblShipFitData] ON [tblMEList].[Equipment Tag] = [tblShipFitData].Equipment)INNER JOIN (tblClass INNER JOIN [tblPlatformList] ON tblClass.Class = [tblPlatformList].Class) ON [tblShipFitData].Vessel = [tblPlatformList].Vessel "
               
    strSQL = strSQL & "WHERE tblClass.Class IN (" & strClassName & ");"
    
    Set qdf = db.QueryDefs("qryClassOutput")
    qdf.SQL = strSQL
    strSheetName = ""
    strSheetName = rs!Class
    strSheetName1 = rs!Class
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "qryClassOutput", strPath, True, strSheetName
    Set qdf = Nothing
    rs.MoveNext
    
    strSheetName = Replace(strSheetName, "(", "_")
    strSheetName = Replace(strSheetName, ")", "_")
    strSheetName = Replace(strSheetName, " ", "_")
    
    Dim XLApp1 As Object
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    ' Open the XLS fle
    Set XLApp1 = CreateObject("Excel.Application")
    XLApp1.Workbooks.Open strPath
    Set xlBook = XLApp1.Workbooks(strPath1)
    'xlBook.Open
    Set xlSheet = xlBook.Worksheets(1)
With XLApp1
    'Keep working in the background for now
    .Application.Visible = False
    .UserControl = True
    
    With xlSheet
    
    .Cells(1, lngStartColumn).FormulaR1C1 = strSheetName1
    .Cells(2, lngStartColumn).FormulaR1C1 = "Present"
    .Cells(2, lngStartColumn + 1).FormulaR1C1 = "No. Platforms"
    .Cells(2, lngStartColumn + 2).FormulaR1C1 = "Units"
        
        
    .Range(xlSheet.Cells(3, lngStartColumn), xlSheet.Cells(334, lngStartColumn)).FormulaR1C1 = "=IF(COUNTIF(" & strSheetName & "!R2C1:R1565C1,'OSP_Analysis'!RC1)>0,1,0)"
    .Range(xlSheet.Cells(3, lngStartColumn + 1), xlSheet.Cells(334, lngStartColumn + 1)).FormulaR1C1 = "=COUNTIF(" & strSheetName & "!R2C1:R1565C4,'OSP_Analysis'!RC1)"
    .Range(xlSheet.Cells(3, lngStartColumn + 2), xlSheet.Cells(334, lngStartColumn + 2)).FormulaR1C1 = "=SUMIF(" & strSheetName & "!R2C1:R1565C1,'OSP_Analysis'!RC1," & strSheetName & "!R2C4:R1553C4)"
    
    Dim MyRange4 As Range
    Dim MyRange5 As Range
    Dim MyRange6 As Range
    Dim MyRange7 As Range
    Dim Cell As Range
    
    Set MyRange4 = xlSheet.Range(xlSheet.Cells(3, lngStartColumn), xlSheet.Cells(334, lngStartColumn + 2))
    Set MyRange5 = xlSheet.Range(xlSheet.Cells(2, lngStartColumn), xlSheet.Cells(334, lngStartColumn + 2))
    Set MyRange6 = xlSheet.Range(xlSheet.Cells(1, lngStartColumn), xlSheet.Cells(1, lngStartColumn + 2))
    Set MyRange7 = xlSheet.Range(xlSheet.Cells(2, lngStartColumn), xlSheet.Cells(2, lngStartColumn + 2))
    
    For Each Cell In MyRange4
        If Cell.Value <> 0 Then
        Cell.Interior.ColorIndex = 6 'Yellow
        Else
        End If
    Next
    
    With MyRange5.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    
    For item = 7 To 10
        With MyRange4.Borders(item)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
    Next
    For item = 7 To 10
        With MyRange6.Borders(item)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
    Next
        
    For item = 7 To 10
        With MyRange7.Borders(item)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
    Next
        
    End With
    .Application.DisplayAlerts = False
    xlBook.SaveAs strPath
    .Workbooks.Close
    .Application.Visible = True
    .Application.DisplayAlerts = True
    .Quit
    
End With
Set XLApp1 = Nothing
lngStartColumn = lngStartColumn + 3
Loop
Set db = Nothing
MsgBox "OSP analysis now complete please find the file in the Output folder", vbOKOnly, "Complete"
Exit_cmdOSP_Click:
    Exit Sub
Err_cmdOSP_Click:
    MsgBox Err.Number & " " & Err.Description
    Resume Exit_cmdOSP_Click
End Sub
 
Last edited:
You must log in or register to reply here.

Similar threads

R
yet another count issue in a query
Replies
2
Views
690
Rat1sully
R
A
Populate Multiple Word Documents with Recordset
Replies
1
Views
4,193
abroniewski
A

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom