Fehler im Code

[BachFel]

Hallo Zusammen,

ich habe folgenden Code der den Laufzeitfehler 5016 anzeigt:

Sub Einlesen()
  Dim sSQLQry As String
  Dim ReturnArray
  Dim Conn As New ADODB.Connection
  Dim mrs As New ADODB.Recordset
  Dim DBPath As String, sconnect As String
  Dim VMName As String
 
  VMName = ThisWorkbook.Worksheets("P-Liste").VMListe.Value
  If ThisWorkbook.Worksheets("P-Liste").Range("B6").Value <> "" Then
    ThisWorkbook.Worksheets("P-Liste").Rows("7:65536").Delete Shift:=xlUp
  End If
  DBPath = ThisWorkbook.FullName
  sconnect = "DSN=Excel Files;DBQ=" & DBPath & ";HDR=Yes;"
  With Conn
    .Provider = "MSDASQL"
    .ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=R:\DataBaseManagement\Expose-Vermietung\VGMBV\Dokumente\Beschreibung1.xls; ReadOnly=False;"
    .Open
  End With
  sSQLSting = "SELECT * From [MO-Liste$] WHERE F6 = '" & VMName & "' ORDER BY 'Referenzbereich anpssen'"
  mrs.Open sSQLSting, Conn
  ThisWorkbook.Worksheets("P-Liste").Range("B7").CopyFromRecordset mrs
  mrs.Close
  Conn.Close
  ThisWorkbook.Worksheets("P-Liste").Range("D7:D65536").NumberFormat = "0%"
  ThisWorkbook.Worksheets("P-Liste").Rows.RowHeight = 15 'AutoFit
End Sub

Bei Debuggen ist der blau markierte Teil der Fehlerbelastete. Kann mir da evtl. jemand weiterhellfen?

Liebe Grüße
Felix

[BachFel]

Hat keiner von euch eine Idee, oder muss ich mein Anliegen iwie konkretisieren?

Freue mich sehr wenn sich jemand die Zeit nehmen könnte

Liebe Grüße
Felix

[BachFel]

Sorry fürs spammen...

Ich habe herausgefunden dass das Makro funktioniert insofern man die Excel die aufgerufen werden soll: Beschreibung1.xls im Hintergrund geöffnet hat. Wie kann ich nun bewerkstelligen das die Excel nicht immer händisch geöffnet werden muss?

Grüße
Felix

[Storax]

Wo hast Du den Code Kopiert?
Oder ist er von Dir??

Wenn Du schon ADODB nutzt, warum nicht mit folgendem Connection-String

Code:

 Const XL_FILE = "insert file name "
        With cn
            .Provider = "Microsoft.ACE.OLEDB.16.0"
            .ConnectionString = "Data Source=" & XL_FILE & "; Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
            .Open
        End With

https://support.microsoft.com/de-de/help...sic-or-vba

Oder es liegt hieran
https://support.microsoft.com/de-de/help...-kb4041681

Nach der Installation dieses Updates kann es passieren, dass Anwendungen, die auf der Microsoft JET-Datenbankengine (Microsoft Access 2007 und ältere nicht-Microsoft-Anwendungen) basieren, beim Erstellen oder Öffnen von Microsoft Excel .xls-Dateien einen Fehler ausgeben. Die Fehlermeldung lautet: „Unerwarteter Fehler vom externen Datenbanktreiber (1). (Microsoft JET-Datenbankengine)“.

Und hier was dazu

[BachFel]

Ist eine Hinterlassenschaft von meinem Vorgänger:

Das Problem ist wie oben beschrieben lösbar, jedoch kommt jetzt ein neuer Fehler auf wenn man aus den Daten ein Word Dok. erstellen mag.
Ich verstehe leider absolut nicht warum das passiert dass nun erneut ein Laufzeitfehler kommt :22:

Code:

Public AktVMName As String
Public VMAnteil As Variant
Public WrdDateiName As String
Public JaNein As Variant
Declare Function GetUserName Lib "advapi32.dll" _
    Alias "GetUserNameA" (ByVal lpBuffer As String, _
    nSize As Long) As Long
Function UserName() As String
   Dim B As String * 100
   Dim L As Long
   L = 100
   GetUserName B, L
   UserName = Left(B, L - 1)
End Function
Sub NachWord(Zeile As Long)
   Dim WordAppl As Object
   Dim WordDoku As Object
   Dim WordText As String
   Dim TabellenBereich1 As Range
   AktVMName = UserName()
   Set WordAppl = CreateObject("Word.Application")
   WordAppl.Visible = True
   [color=#ffcc33]Set WordDoku = WordAppl[/color].Documents.Add(ThisWorkbook.Path & "R:\DataBaseManagement\Expose-Vermietung\VGMBV\Dokumente\STRABAG Property and Facility Services GmbH-d.dot")
   WordDoku.Activate
  
   'Eintragen eine Wertes
   '  WordDoku.Bookmarks("vonExcel").Range.Text = WordText
  
   'Eintragen eine Wertes
   '  WordDoku.Bookmarks("ExcelWert1").Range.Text = Range("A15")
  
   'eintragen einer Tabelle zu Fuß
   '  For Each TabellenBereich1 In ThisWorkbook.Worksheets("Übersicht").Range("B:B")
   '    If LCase(TabellenBereich1) = "x" Then
   '      WordText = WordText & Chr(10) & TabellenBereich1.Offset(0, 1) & Chr(9) & TabellenBereich1.Offset(0, 2)
   '    End If
   '  Next
  
   'Kopieren einer Tabelle gesamt
  
   WordDoku.Bookmarks("VMT_VermietungsManager").Range.Text = AktVMName 'ThisWorkbook.Worksheets("Übersicht").Range("C2")
   WordDoku.Bookmarks("VMT_Datum").Range.Text = Format(Now(), "DD.MM.YYYY")
   WordDoku.Bookmarks("VMT_Unterschrift1").Range.Text = AktVMName 'ThisWorkbook.Worksheets("Übersicht").Range("C2")
   '  ThisWorkbook.Worksheets("VMBlattVermiet").UsedRange.CopyPicture xlScreen, xlBitmap
   '  WordDoku.Bookmarks("VMT_Neuvermietungen").Range.Pasteandformat (wdPasteDefault)
   '  Application.CutCopyMode = False
  
   'eintragen einer Tabelle zu Fuß
   WordText = ""
   For Each TabellenBereich1 In ThisWorkbook.Worksheets("P-Liste").Range("B6,D6:H6,I6:J6,N6,P6:U6,W6,Y6,AA6") '("B:B")
      If LCase(TabellenBereich1) <> "" Then
         If Left(TabellenBereich1.Offset(0, 0), 8) = "Relevant" Then
            WordText = WordText & TabellenBereich1.Offset(0, 0) & Chr(9) & TabellenBereich1.Offset(Zeile - 6, 0).FormulaLocal & Chr(10)
         Else
            WordText = WordText & TabellenBereich1.Offset(0, 0) & Chr(9) & TabellenBereich1.Offset(Zeile - 6, 0) & Chr(10)
            'WordText = WordText & Chr(10) & TabellenBereich1.Offset(0, 1) & Chr(9) & TabellenBereich1.Offset(0, 2)
         End If
      End If
   Next
   WordDoku.Bookmarks("VMT_Neuvermietungen").Range.Text = WordText
  
   WordDateiName = "C:\temp\" & AktVMName & "_" & ThisWorkbook.Worksheets("P-Liste").Cells(Zeile, 2) & ".doc" 'sFile
   WordDoku.SaveAs WordDateiName
   'WordDoku.SaveAs ThisWorkbook.Path & "\Dokumente\" & AktVMName & "_" & ThisWorkbook.Worksheets("P-Liste").Cells(Zeile, 2) & ".doc" 'sFile
   JaNein = MsgBox("Das Worddokument wurde als folgende Datei gespeichert: " & WordDateiName & " . Soll die Datei geschlossen werden?", vbInformation + vbYesNo, "Fertig")
   If JaNein = 6 Then
      'Dokument schließen
      WordDoku.Close
      'Word schließen
      WordAppl.Quit
   End If
  
   Set WordDoku = Nothing
   Set WordAppl = Nothing
  
End Sub

[Storax]

Verwende Code Tags, ist ja schrecklich!

Hast Du den Connection String umgestellt?
Und Deine oben beschriebene Lösung ist IMHO keine Lösung.
Wenn es tatsächlich am Update liegt, wie in meinen Links beschrieben,
ist es erst Recht keine Lösung. 

Und "neuer Fehler" ist sicher keine Fehlerbeschreibung. Wer soll da was mit anfangen.
Und ob der was mit dem ersten zu tun hat, woher soll ich das wissen.

Also, erst mal den ersten Fehler richtig beheben!

[BachFel]

Morgen Storax,

ich verstehe (mit sehr begrenzten Kenntnissen) deinen Vorschlag wie folgt:

Sub Einlesen()
  Dim sSQLQry As String
  Dim ReturnArray
  Dim Conn As New ADODB.Connection
  Dim mrs As New ADODB.Recordset
  Dim DBPath As String, sconnect As String
  Dim VMName As String
 
  VMName = ThisWorkbook.Worksheets("P-Liste").VMListe.Value
  If ThisWorkbook.Worksheets("P-Liste").Range("B6").Value <> "" Then
    ThisWorkbook.Worksheets("P-Liste").Rows("7:65536").Delete Shift:=xlUp
  End If
  DBPath = ThisWorkbook.FullName
  sconnect = "DSN=Excel Files;DBQ=" & DBPath & ";HDR=Yes;"
 Const XL_FILE = "R:\DataBaseManagement\Expose-Vermietung\VGMBV\Dokumente\Beschreibung1.xls"
        With cn
            .Provider = "Microsoft.ACE.OLEDB.16.0"
            .ConnectionString = "Data Source=" & XL_FILE & "; Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
            .Open
        End With
  sSQLSting = "SELECT * From [MO-Liste$] WHERE F6 = '" & VMName & "' ORDER BY 'Referenzbereich anpssen'"
  mrs.Open sSQLSting, Conn
  ThisWorkbook.Worksheets("P-Liste").Range("B7").CopyFromRecordset mrs
  mrs.Close
  Conn.Close
  ThisWorkbook.Worksheets("P-Liste").Range("D7:D65536").NumberFormat = "0%"
  ThisWorkbook.Worksheets("P-Liste").Rows.RowHeight = 15 'AutoFit
End Sub

Dann poppt allerdings der Fehler zum Debuggen beim Provider auf.

[BachFel]

Wenn man die Excel öffnet erscheint folgende Nachricht:

Ohne dass ich iwas am Code angepasst habe.

Die Barcodegröße kann nicht aktualisiert werden.

Möglicherweise wurden Aktive Inhalte deaktiviert (siehe Trust Center für weitere Einstellungen). Sie können diese Warnung in den TBarCode Panel Optionen ausschalten.

(Die Objekt-Eigenschaften des OLEObject-Objektes kann nicht zugeordnet werden.)


Ich bin max. überfragt :22: