Data transfer from Access to Excel problem

[geralf]

Hi,

I have used a procedure to transfer data to Excel from Access. I'm using the Excel library from Access. This has worked fine ubtil I added a new sheet to the workbook. Everything works as it should. When I close down Excel, (Which is started when the transfer is in progress) I'm asked to save the file which I do. All sheets is showing in the workbook when Excel closes. If I now go and open the file again, Excel is opened but no workbook shows up. However, if I go to View and select Full Screen, they are displayed. When I close the 'Full screen', it is normal with toolbars etc and the workbook is there. I post the code that is run from Access. Can anyone please tell me what's making this behaviour?

Sub XLHTransfer(Fname As String, XLTmp As String, FDato As Date, TDato As Date)
    Dim FExist As Boolean
    Dim Response As Integer
    Dim J As Integer
    Dim I As Integer
    Dim CritCID As Long
    Dim FD As String
    Dim TD As String
    Dim strInfo As String
    Dim B As Boolean
    Dim K As Integer
    Dim P(9) As Integer 'Variabel for Celleposisjoner i Excel-arket
    Dim CurrentValue As Variant
    Dim CurrentField As Variant
    Dim xlApp As Excel.Application
    Dim ExcelRunning As Boolean
    Dim Sht As Excel.Worksheet
    Dim Wbk As Excel.Workbook
    Dim CurCell As Object
    Dim rst0 As Recordset
    Dim rst As Recordset
    Dim rst2 As Recordset
    Dim dbs As Database
    P(0) = 1: P(1) = 2: P(2) = 6: P(3) = 7: P(4) = 8
    Set dbs = CurrentDb
    strInfo = "Prosesserer data for Hydro" & vbCrLf & vbCrLf _
            & "Dette kan ta noe tid, vennligst vent....."
    DoCmd.OpenForm "frmMessageBox", acNormal, , , acFormEdit, acWindowNormal, strInfo
    DoCmd.Hourglass True
    DoCmd.RepaintObject acForm, "frmMessageBox"
    FD = DatePart("m", FDato) & "/" & DatePart("d", FDato) & "/" & DatePart("yyyy", FDato)
    TD = DatePart("m", TDato) & "/" & DatePart("d", TDato) & "/" & DatePart("yyyy", TDato)
    
    Set rst = dbs.OpenRecordset("SELECT * FROM H19HeaderLineToExcel " _
            & "WHERE Dato >= #" & FD & "# And Dato <= #" & TD & "#;")
    If (rst.BOF And rst.EOF) Then
        DoCmd.Close acForm, "frmMessageBox", acSaveNo
        DoCmd.Hourglass False
        MsgBox ("Der er ingen data å overføre for valgte periode!")
    Else
        rst.MoveLast: rst.MoveFirst
        '***************Init Excel******
        ExcelRunning = IsExcelRunning()
        If ExcelRunning Then
            Set xlApp = GetObject(, "Excel.Application")
        Else
            Set xlApp = CreateObject("Excel.Application")
        End If
        With xlApp
            .Visible = True
            .WindowState = xlMaximized
            .Cursor = xlWait
            If fIsFileDIR(Fname) <> 0 Then
                Set Wbk = .Workbooks.Open(Filename:=Fname, _
                            ReadOnly:=False, AddToMru:=False)
            Else
                Dim NewCID As Long
                Dim CurrentCID As Long
                Set Wbk = .Workbooks.Add(XLTmp)
                Wbk.SaveAs Fname
            End If
            Set Sht = Wbk.Sheets("Produksjonsdata")
            Sht.Select
'***********Datatransfer************************
            Sht.Unprotect ("emerhoff")
            Sht.Cells(3, 2).Value = Format(Now(), "dd.mm.yyyy kl. hh:nn")
            Sht.Cells(4, 2).Value = Format(FDato, "dd.mm.yyyy")
            Sht.Cells(5, 2).Value = Format(TDato, "dd.mm.yyyy")
            J = 9
            rst.MoveFirst
            Do While Not rst.EOF
                For K = 0 To 4
                    CurrentField = rst(K)
                    Sht.Cells(J, P(K)).Value = CurrentField
                Next K
                CritCID = rst!CID
                
                Set rst2 = dbs.OpenRecordset("SELECT * FROM H25Drossdetaljer " _
                        & "WHERE CID=" & CritCID & ";")
                rst2.MoveLast
                rst2.MoveFirst
                Do While Not rst2.EOF
                    For I = 0 To rst2.Fields.Count - 1
                    CurrentField = rst2(I)
                        Sht.Cells(J, I + 2).Value = CurrentField
                    Next I
                    rst2.MoveNext
                    J = J + 1
                Loop
                rst.MoveNext
            Loop
            rst2.Close
'************Analyser************************
            AnalysisUpdate
            Set Sht = Wbk.Sheets("Analyser")
            Sht.Select
            Sht.Unprotect ("emerhoff")
            J = 3
            rst.MoveFirst
            Do While Not rst.EOF
                CritCID = rst!CID
                Set rst2 = dbs.OpenRecordset("SELECT * FROM H30Analyser " _
                        & "WHERE CID=" & CritCID & ";")
                If Not (rst2.BOF And rst2.EOF) Then
                    rst2.MoveLast
                    rst2.MoveFirst
                    Do While Not rst2.EOF
                        If IsNull(rst2!SI) Then
                            Sht.Cells(J, 1).Value = rst2!TCID
                            Sht.Cells(J, 2).Value = "NoA"
                        Else
                            For I = 0 To rst2.Fields.Count - 2
                            CurrentField = rst2(I)
                            Sht.Cells(J, I + 1).Value = CurrentField
                            Next I
                        End If
                        rst2.MoveNext
                        J = J + 1
                    Loop
                Else
                    Sht.Cells(J, I).Value = "NoA"
                    J = J + 1
                End If
                rst.MoveNext
            Loop
            rst.Close: rst2.Close
'**************Drossbevegelser**********
            Set Sht = Wbk.Sheets("Drossleveranser")
            Sht.Select
            Set rst2 = dbs.OpenRecordset( _
                "SELECT * " & _
                "FROM qselDrossbevegelser " & _
                "WHERE " & _
                    "TI >= #" & FD & "# And TI <= #" & TD & "#;")
            J = 4
            If Not rst2.EOF Then
                rst2.MoveLast: rst2.MoveFirst
            End If
            
            Do While Not rst2.EOF
               For I = 0 To rst2.Fields.Count - 1
                    CurrentField = rst2(I)
                    If I = 2 And rst2!VLEVERT < 0 Then
                        Range(Cells(J, 4), Cells(J, 6)).Interior.ColorIndex = 3
                        Range(Cells(J, 4), Cells(J, 6)).Interior.Pattern = xlSolid
                        Range(Cells(J, 4), Cells(J, 6)).Interior.PatternColorIndex = xlAutomatic
                    End If
                    Sht.Cells(J, I + 1).Value = CurrentField
                Next I
                rst2.MoveNext
                J = J + 1
            Loop
            rst2.Close
'**************Ferdig**********************
            DoCmd.Close acForm, "frmMessageBox", acSaveNo
            DoCmd.Hourglass False
            Set Sht = Wbk.Sheets("Produksjonsdata")
            Sht.Select
            Sht.Range("A1").Select
            .Cursor = xlDefault
            'Sht.Protect ("emerhoff")
            Set Sht = Nothing
            Set Wbk = Nothing
            
            Set xlApp = Nothing
        End With
    End If
End Sub

 

[Dreamboat]

Before your code closes the workbook, try adding this line or something similar:

Windows.Arrange ArrangeStyle:=xlArrangeStyleTiled

 

[geralf]

Hi Anne

Thanks for your reply.

I haven't tried your augestion using VBA, but I've tried it in the Excel app. It don't show the workbook. Only 'Full Screen' makes the workbook visible. I've just started debugging now, and I found that it affects the Excel application itsself. This because if I open another workbook, it is also invisible. I have Excel Menu bar and the toolbars but no sheets. The box that shows the current cell shows that 'A2' is selected and the formula lines shows 'Date' which is correct. I'll try your suggestion in VBA and see if it makes any difference. I'll post back later.

Thanks again for your reply.

 

[geralf]

Ok. I've found what's causing this but not how to resolve it. I hope someone can help me out here.

The disappearing sheets dissapear when the line
Sht.Range(Cells(J, 4), Cells(J, 6)).Interior.ColorIndex = 3
is used.

The sheets don't dissapear when I use this:
Sht.Range("A1").Interior.ColorIndex = 3

I've used "A1" just as an example. This is also the reason for using the Cells() property , so I don't need to build the cells as "A1" and so on for each row in the sheet.

Thanks in advance for any help.

 

[geralf]

I've resolved it. I had not referenced the cells I wanted colored properly. By adding a period in front of the Cells property, it worked as it should.

here's the way I referenced the cells

Do While Not rst2.EOF
For I = 0 To rst2.Fields.Count - 1
CurrentField = rst2(I)
If I = 2 And rst2!VLEVERT < 0 Then
Sht.Range(.Cells(J, 4), .Cells(J, 6)).Interior.ColorIndex = 3
End If
Sht.Cells(J, I + 1).Value = CurrentField
Next I
rst2.MoveNext
J = J + 1
Loop
rst2.Close

Thanks for your interest.