Suche Fehler im Code

[RalfZ]

Also ich komme einfach nicht mehr weiter bekomme beim 2.Aufruf der Anwendung immer einen Fehler wohlgemerkt erst beim 2. Aufruf. Bedeutet für mich das ich irgendetwas nicht ordentlich schließe.
Die Meldung
" Die Methode Cells für das Object _Global ist fehlgeschlagen"

Der Code
Private Sub cmb_toExcel_Click()
Dim oExcel As Excel.Application, Tmp, TTD, Addr, DB As DAO.Database, rs As DAO.Recordset, _
TransP As Boolean, _
MerkAbt, MerkFA, Auditnr, Datum As Date, Name As String, _
I As Long, J As Long, St As Long, nr As Long, Sp As Long
Dim oExcelrange As Excel.Sheets
Dim strSQL As String
Dim QZ
Set DB = CurrentDb '
Auditnr = Me.QEAuditnr
Datum = Me.Datum


strSQL = "(SELECT DISTINCTROW tblQEKopf.QEAuditnr, tblQEKopf.Abteilung, tblQEKopf.Datum, tblQEKopf.Auditor, Teilnr_tab.Teilnummer, Teilnr_tab.[Index Benennung], tblQEKopf.[AF/FS], tblQEKopf.Maschinennr, Maschinen_tab.art, Maschinen_tab.Benennung, tblQEKopf.Kostenstelle, tblQEKopf.Qentgeld, tblQEKopf.Verteiler, tblQEFragen.nr, tblQEFragen.Fragen, tblQEAntworten.Bemerkung" _
& " FROM ((tblQEKopf INNER JOIN Maschinen_tab ON tblQEKopf.Maschinennr = Maschinen_tab.Einzel_Nr) INNER JOIN Teilnr_tab ON tblQEKopf.TeilnrID = Teilnr_tab.IndexT) INNER JOIN (tblQEAntworten INNER JOIN tblQEFragen ON tblQEAntworten.Fragenr = tblQEFragen.nr) ON tblQEKopf.ID_QEKopf = tblQEAntworten.ID_QEKopf" _
& " WHERE (((tblQEKopf.QEAuditnr) Like '" & Auditnr & "') And ((tblQEAntworten.Antwort) = No))ORDER BY tblQEFragen.nr"
Set rs = DB.OpenRecordset(strSQL)

rs.MoveFirst

On Error Resume Next
err.Clear

Set oExcel = GetObject(, "Excel.Application ")


If err.Number <> 0 Then Set oExcel = CreateObject("Excel.Application") 'oExcel = GetObject("C:\wlqaudit\mappe2.xls")
On Error GoTo 0
With oExcel
.Visible = True
.Workbooks.Open "C:\WLQAudit\AbwBerichte\Vorlage\Abweichungsbericht_vorlage.XLT"

Tmp = ""
Tmp = .ActiveWorkbook.Name
On Error GoTo 0
If Tmp <> "Abweichungsbericht_vorlage1" Then
MsgBox "Vorlage nicht gefunden"
End If


.Range("QEAuditnr") = CStr(Nz(rs.Fields(0).Value, ""))
.Range("Abteilung") = CStr(Nz(rs.Fields(1).Value, ""))
.Range("Datum") = CStr(Nz(rs.Fields(2).Value, ""))
.Range("Auditor") = CStr(Nz(rs.Fields(3).Value, ""))
.Range("Teilnummer") = CStr(Nz(rs.Fields(4).Value, ""))
.Range("IndexBenennung") = CStr(Nz(rs.Fields(5).Value, ""))
.Range("AF") = CStr(Nz(rs.Fields(6).Value, ""))
.Range("Maschine") = CStr(Nz(rs.Fields(7).Value, "")) & " - " & CStr(Nz(rs.Fields(8).Value, "")) & " " & CStr(Nz(rs.Fields(9).Value, ""))
.Range("Verteiler") = CStr(Nz(rs.Fields(12).Value, ""))


J = 13 'zeile Beginn Detail
nr = 1 'Maßnahmenzähler
Do While Not rs.EOF
St = 13 'spalte Abfrage Start
J = J + 1 'zeile
Sp = 1 'spalte Tabelle
.Cells(J, Sp) = nr 'Maßnahmennr
nr = nr + 1

For I = St To rs.Fields.Count - 1
If I < 15 Then
Sp = Sp + 1
.Cells(J, Sp) = CStr(Nz(rs.Fields(I).Value, ""))
Else
.Cells(J, Sp) = .Cells(J, Sp) & Chr(10) & CStr(Nz(rs.Fields(I).Value, ""))
End If
Next I

rs.MoveNext
Loop
.Range("Kopf").Locked = True
.Range(Cells(14, 4), Cells(J, 11)).Select
With .Selection
.Interior.ColorIndex = 34
.Locked = False
End With


'Password evtl. ändern
ActiveSheet.Protect password:="WLQ11", DrawingObjects:=True, Contents:=True, Scenarios:=True
Name = "AbwBericht von " & Replace(Auditnr, "/", "-") & " vom " & Datum

'.Visible = False
.Quit
Set oExcel = Nothing

Exit Sub

Ich weiß das es am ende End Sub heißt aber der Code geht noch weiter und zum testen ist Exit Sub immer gut.

Gruß Ralf

 

[Orakel]

Hallo RalfZ

Kann es sein, dass Du in diesem Abschnitt Deinen Fehler hast?

    rs.MoveNext
  Loop
  .Range("Kopf").Locked = True

------>  .Range(Cells(14, 4), Cells(J, 11)).Select
  Hier greifst Du ja auf das Rangeobject des oExcel
  Objektes zu, während Du die Cells Objecte Deiner
  aktiven Anwendung ansprechen willst. Ich würde sagen,
  der Code sollte so aussehen:

  .Range(.Cells(14, 4), .Cells(J, 11)).Select


  With .Selection
  .Interior.ColorIndex = 34
  .Locked = False
End With

maybe it works

Gruß
Das Orakel