Fehlermeldung Subscript out of range
04.05.2017 11:19:40
stef26
ich hab da ein Problem, bei dem ich eure Hilfe bräuchte.
Ich habe ein Macro welches eine Excelliste unter einem bestimmten Namen abspeichert.
(Ich weiß mittlerweile, dass man kopieren mit select nicht machen sollte)
Es geht nur darum, dass wenn ich in Deutschland die XLS speichern möchte,
dann funktioniert alles super.
Selbst wenn ich in China das Macro aufrufe funktioniert es einwandfrei.
Rufen meine Kollegen in China das selbst auf, bekommen sie die Fehlermeldung:
Subscript out of range
Kann das mit der Excelversion zusammenhängen, dass in China eine alte XLS Version läuft, oder gibt es Länderspezifische Sachen, die man bei VBA berücksichtigen muß?
Sub Speichern()
Rem Abbruch wenn Daten nicht gepflegt sind, die zum speichern benödigt werden
If Range("E7").Text = "" Then MsgBox ("Kein E-Stand gepflegt!!!"): Exit Sub
If Range("J3").Text = "" Then MsgBox ("Keine Änderungsnummer/Datum gepflegt!!!"): Exit Sub
If Range("I7").Text = "" Then MsgBox ("Serie? Muster? Angebot?"): Exit Sub
'Makrobremsen lösen
With Application
.ScreenUpdating = False
End With
' Übergabeprotokoll neu sichern
Sheets("Übergabeprotokoll").Select
ActiveWindow.SmallScroll ToRight:=-6
Range("B4:CI4").Select
Selection.Copy
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1:CI2").Select
Selection.Copy
'Übergabeprotokoll übergeben
Dim LZ As Long
Dim Pfad As String
If ThisWorkbook.Sheets("Grunddaten").Range("J9").Value = 1 Then
Pfad = ThisWorkbook.Sheets("Setup").Range("B1")
Else
Pfad = ThisWorkbook.Sheets("Setup").Range("B2")
End If
Workbooks.Open Filename:=Pfad & "\Archiv\KalkulationenFBG.xlsx"
If Err = 1004 Then
msg = MsgBox("KalkulationenFBG.xlsx not found!")
Exit Sub
End If
Rem Bereich kopieren
Application.Workbooks("KalkulationenFBG.xlsx").Activate
LZ = Sheets("Kalkuliert2015").Cells(Rows.Count, 1).End(xlUp).Row + 1
Sheets("Kalkuliert2015").Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial Paste:= _
xlValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks("KalkulationenFBG.xlsx").Close SaveChanges:=True
' Übergabeprotokoll in Werte umwandeln
Sheets("SMD-Datenbank").Select
Range("A2:P3").Select
Selection.Copy
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A2:P3").Select
Selection.Copy
'Übergabeprotokoll übergeben
Dim LZ1 As Long
Workbooks.Open Filename:=Pfad & "\Archiv\SMD-Zeiten-Datenbank.xlsx"
If Err = 1004 Then
msg = MsgBox("Die Datei existiert nicht.")
Exit Sub
End If
Rem Bereich kopieren
Application.Workbooks("SMD-Zeiten-Datenbank.xlsx").Activate
LZ1 = Sheets("SMD-Datenbank").Cells(Rows.Count, 1).End(xlUp).Row + 1
Sheets("SMD-Datenbank").Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial Paste:= _
xlValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks("SMD-Zeiten-Datenbank.xlsx").Close SaveChanges:=True
Sheets("Grunddaten").Select
'Makrobremsen zurückstellen
With Application
.ScreenUpdating = True
End With
' Speichern
Dim objFSO As Object
Dim ALTXLS As String
Dim ARCHIVXLS As String
'Abfrage Erlangen oder SZN
If ThisWorkbook.Sheets("Grunddaten").Range("J9").Value = 1 Then
'Erlangen
ARCHIVXLS = ThisWorkbook.Sheets("Setup").Range("B15").Text 'wohin
ALTXLS = ThisWorkbook.Sheets("Setup").Range("B16").Text 'was
ALTXLS2 = ThisWorkbook.Sheets("Setup").Range("B17").Text 'was
Else
'SZN
ARCHIVXLS = ThisWorkbook.Sheets("Setup").Range("B18").Text 'wohin
ALTXLS = ThisWorkbook.Sheets("Setup").Range("B19").Text 'was
ALTXLS2 = ThisWorkbook.Sheets("Setup").Range("B20").Text 'was
End If
Rem Archivieren
If Range("A16") "" Then 'Archivieren nicht notwendig
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error GoTo weiter
objFSO.MoveFile ALTXLS, ARCHIVXLS ' was,wohin
objFSO.MoveFile ALTXLS2, ARCHIVXLS ' was,wohin
Else
End If
weiter:
Rem speichern
'Da speichern und speichern unter deaktiviert ist
Application.EnableEvents = False
'Speichern der Kalkulation
If ThisWorkbook.Sheets("Grunddaten").Range("J9").Value = 1 Then
'Erlangen
Pfadname = ThisWorkbook.Sheets("Setup").Range("B1").Text
Else
'SZN
Pfadname = ThisWorkbook.Sheets("Setup").Range("B2").Text
End If
Dateiname = ThisWorkbook.Sheets("Setup").Range("B12").Text
ActiveWorkbook.SaveAs Pfadname & Dateiname
'Da speichern und speichern unter deaktiviert ist
Application.EnableEvents = True
Sheets("Grunddaten").Select
End Sub