ich hab mir ein Makro gebaut, dass vor zwei Wochen noch funktioniert hat. Jetzt funktioniert es nicht mehr und ich weiß nicht warum.
Es hängt sich immer an der Stelle auf:
If Not .InitialFileName Like "XMLVJT2_?_Q?.xls" Then
MsgBox "Möglicherweise haben Sie eine falsche Datei ausgewählt. Bitte versuchen Sie es erneut!"
GoTo VorletztesQuartal
End If
Das heißt auch wenn die ausgewählte Datei in der Form ist kommt die Fehlermeldung.
Kann mir einer helfen?
PS: Ohne das funktioniert es einwandfrei nur ohne die Fehlermeldung (MsgBox), die ich gerne drinhaben möchte.
Private Sub CommandButton1_Click()
Dim WStmp As Worksheet
Dim ZWS As Worksheet
Dim QWSName As String
Dim ZWSFirstRange As String
Dim ZWSSecondRange As String
Dim FileStr As Variant
Dim PathStr As Variant
Dim WB As Workbook
Set ZWS = Worksheets("Quartaltabellen")
PathStr = "D:\D14\Panne\HerrMeyer\Orignal"
QWSName = "Tabelle1"
ZWSFirstRange = "A1"
ZWSSecondRange = "A230"
VorletztesQuartal:
'Vorletztes Quartal
With Application.FileDialog(msoFileDialogOpen)
.Title = "Vorletztes Ouartal einfügen"
.InitialFileName = "XMLVJT2_?_Q?.xls"
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "ExcelDateien", "*.xls"
.Show
If .SelectedItems.Count 1 Then
MsgBox "Vorletztes Quartal nicht aktualisiert"
GoTo LetztesQuartal
End If
FileStr = .SelectedItems(1)
If Not .InitialFileName Like "XMLVJT2_?_Q?.xls" Then
MsgBox "Möglicherweise haben Sie eine falsche Datei ausgewählt. Bitte versuchen Sie _
es erneut!"
GoTo VorletztesQuartal
End If
End With
Set WStmp = Worksheets.Add
Set WB = Workbooks.Open(FileStr)
WB.Worksheets(1).UsedRange.Copy Destination:=WStmp.Range(ZWSFirstRange)
WB.Close
Set WB = Nothing
LetztesQuartal:
'Letztes Quartal
With Application.FileDialog(msoFileDialogOpen)
.Title = "Letztes Ouartal einfügen"
.InitialFileName = "XMLVJT2_?_Q?.xls"
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "ExcelDateien", "*.xls"
.Show
If .SelectedItems.Count 1 Then
MsgBox "Letztes Quartal nicht aktualisiert"
GoTo Ende
End If
FileStr = .SelectedItems(1)
End With
Set WB = Workbooks.Open(FileStr)
WB.Worksheets(1).UsedRange.Copy Destination:=WStmp.Range(ZWSSecondRange)
WB.Close
Set WB = Nothing
ZWS.UsedRange.Clear
WStmp.UsedRange.Copy Destination:=ZWS.Range(ZWSFirstRange)
Ende:
On Error Resume Next
Application.DisplayAlerts = False
WStmp.Delete
Set WStmp = Nothing
Application.DisplayAlerts = False
WB.Close
Set WB = Nothing
End Sub