Datei bereits geöffnet - VBA
24.09.2014 10:07:40
Marek
in meinem Makro kann ich den Fehler (Datei2 bereits geöffnet) nicht finden. Vielleicht sieht ihn jemand von euch.
Sub Aktualisieren()
Application.ScreenUpdating = False
Dim j%, k%, m%, strDateiname$
Dim wkbOld As Workbook (Berichtsdatei, aus der das Makro gestartet wird und in die Werte eingespielt werden)
Dim ISTUV&
[ ]
Dim strNachricht$
j = Year(CDate(Range("A1")))
k = Range("Y1")
m = Month(CDate(Range("A1")))
Set wkbOld = ActiveWorkbook
'Datei1 öffnen
strDateiname = "PFAD " & j & "\" & m & "\Details\" & k & "_Detail_" & m & ".xls"
If WkbExists(strDateiname) Then Workbooks.Open Filename:=strDateiname Else GoTo Fehler
Sheets("Tabelle1").Select
On Error Resume Next
'IST-Werte auslesen
ISTUV = -(Columns("B:B").Find(What:="Suchbegriff1").Offset(0, 2)) / 1000
[ ]
Sheets("Tabelle2").Select
'IST-Kennzahlen auslesen
ISTAWT = -Columns("B:B").Find(What:="Suchbegriff2").Offset(0, 2)
[ ]
wkbOld.Activate
'Werte in Berichtsdatei einfügen
Cells(6, m + 1).Value = ISTUV
Cells(49, m + 1).Value = ISTAWT
'Formeln kopieren
Dim S&
Range("B6").End(xlToRight).Offset(0, 0).Activate
If m = 1 Then GoTo Weiter Else
If m = 12 Then S = 13 Else S = ActiveCell.Column
Range("B9").Copy
ActiveSheet.Range(Cells(9, 3), Cells(9, S)).PasteSpecial Paste:=xlPasteFormulas
[ ]
Weiter:
'Datei1 schließen
Dim wkb As Workbook
Set wkb = Workbooks.Open(strDateiname)
wkb.Close savechanges:=False
Set wkb = Nothing
Dim AUS_CHARGED_MON&
Set wkbOld = ActiveWorkbook
'Datei2 öffnen
strDateiname = "PFAD\" & j & "\" & "Datei " & m & "_" & j & ".xlsx"
If WkbExists(strDateiname) Then Workbooks.Open Filename:=strDateiname Else GoTo Fehler
Sheets("Tabelle1").Select
'Daten auslesen
AUS_CHARGED_MON = (Columns("A:A").Find(What:=k).Offset(0, 15)) * 1000
[ ]
wkbOld.Activate
'Werte in Berichtsdatei einfügen
Cells(70, m + 1).Value = AUS_CHARGED_MON / 10
'Datei2 schließen
Dim wkbU As Workbook
Set wkbU = Workbooks.Open(strDateiname)
wkbU.Close savechanges:=False
Set wkbU = Nothing
Calculate
Application.ScreenUpdating = True
Exit Sub
Fehler:
strNachricht = "Datei " & Chr(13) & strDateiname & Chr(13) & "existiert nicht!"
MsgBox strNachricht, vbExclamation
Application.ScreenUpdating = True
End Sub
Private Function WkbExists(strDateiname As String) As Boolean
Dim wkb As Workbooks
If Dir(strDateiname) = "" Then
WkbExists = False
Else
WkbExists = True
End If
End Function