Temporäre Datei
22.01.2019 16:02:01
Tom
ich bin immer noch nicht mit dem Problem weitergekommen.
Mein Makro liest unter einem festzugteilten Laufwerk alle darin abgelegten Excel-Dateien aus und legt die Inhalte ab. Wenn jedoch einer der Dateien geöffnet ist, bricht die Prozedur (bei .Open strSQL) ab und ich muss warten bis die Datei wieder geschlossen wird, damit ich keinen Abbruch erhalte. Ich möchte die geöffneten Dateien beim Auslesen überspringen lassen oder die temporäre Kopie auslesen lassen. Unten folgend der Code. Kann sich das jemand anschauen und unterstützen?
Gruß Tom
Sub Fahrzeugdatei_auslesen()
Dim sPath$, sDir$, ArFile()
Dim n&, nRow&
Dim ArInhalt
Dim iCalc%
'hier den Pfad angeben
sPath = "L:\"
sPath = IIf(Right$(sPath, 1) "\", sPath & "\", sPath)
sDir = Dir(sPath & "*.xlsm", vbNormal)
Do While sDir ""
ReDim Preserve ArFile(n)
ArFile(n) = sDir
n = n + 1
sDir = Dir()
Loop
If n > 0 Then
With Application
iCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
For n = LBound(ArFile) To UBound(ArFile)
ArInhalt = oExAbfrage(sPath & ArFile(n), "Fahrzeugdatei$K2:AB3", True)
If IsArray(ArInhalt) Then
With Tabelle3
If nRow = 0 Then
.Range("B2:C" & .Rows.Count).ClearContents
nRow = 2
End If
With .Cells(nRow, 2).Resize(UBound(ArInhalt))
.Value = ArInhalt
.Offset(, 1).Value = ArFile(n)
End With
' nRow = nRow + 12
nRow = nRow + 14
End With
End If
Next n
.ScreenUpdating = True
.EnableEvents = True
.Calculation = iCalc
End With
End If
End Sub Option Explicit
'ab xl2007
Private Const cProvider As String = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ="
Private cnMDB As Object ' oder ADODB.Connection -> 'Verweis auf: Microsoft ActiveX Data Objects ...
Private adoRS As Object ' oder ADODB.Recordset -> 'Verweis auf: Microsoft ActiveX Data Objects ...
Private Sub Close_Datenbank()
On Error Resume Next
adoRS.Close
Set adoRS = Nothing
cnMDB.Close
Set cnMDB = Nothing
End Sub
Private Sub ADO_Connect(strFile$)
Dim sPath$, sAdoConnectString$
Set cnMDB = CreateObject("ADODB.Connection") '
'1. Version so
sAdoConnectString = cProvider & strFile
cnMDB.Open sAdoConnectString
End Sub
Private Sub Oben_Recordset(ByVal strSQL$)
Set adoRS = CreateObject("ADODB.Recordset")
With adoRS
.ActiveConnection = cnMDB
.CursorLocation = 3
.CursorType = 2
.LockType = 3
.Open strSQL
End With
End Sub
Function oExAbfrage(ByVal strFile$, ByVal sTabAndRange$, Optional booCloseDB As Boolean = False)
Dim strSQL$, arValues(), n&, nCounter&
If cnMDB Is Nothing Then ADO_Connect strFile
If cnMDB Is Nothing Then GoTo ErrorConnect 'Error
strSQL = "SELECT * FROM [" & sTabAndRange$ & "]"
If adoRS Is Nothing Then
Oben_Recordset strSQL
If adoRS Is Nothing Then GoTo ErrorConnect 'Error
End If
With adoRS
If Not .BOF Then
ReDim Preserve arValues(1 To 1, 1 To .Fields.Count)
For n = 0 To .Fields.Count - 1
If .Fields(n) "" Then nCounter = nCounter + 1: arValues(1, nCounter) = .Fields(n).Value
Next n
ReDim Preserve arValues(1 To 1, 1 To nCounter)
oExAbfrage = Application.Transpose(arValues)
End If
End With
If booCloseDB Then Close_Datenbank
Exit Function
ErrorConnect:
Close_Datenbank
oExAbfrage = "Error"
End Function