Fehler in Modul
13.05.2013 22:46:18
bully
Mit Hilfe diese Forums habe ich vor einiger Zeit untenstehende Prozedur erstellt.
Diese ist auf zwei Rechnern installiert. Auf dem Ersten läuft sie mit Excel 2010 und Windows 7 ohne Fehler. Auf dem Zweiten läuft sie ebenfalls mit Excel 2010 aber auf Windows XP. Auf diesem Rechner bleibt die Prozedur an der fett markierten Stelle stehen,ohne eine Fehlermeldung. Kann mir jemand sagen wieso? Der Wechsel in die Datei Auswertung.xls ins Sheet "Daten" funktioniert nicht mehr. Mache ich den Wechsel manuell, und Starte die Prozedur wieder mit dem einfügen der Daten läuft sie fehlerfrei weiter.
Danke für eure Tipps
Gruss
bully
Option Explicit
Sub Import()
Application.ScreenUpdating = False
On Error GoTo Fehlerbehandlung
noch_einmal:
If MsgBox("Neue Daten importieren - Ja/Nein", vbYesNo + vbQuestion, " nur zur Sicherheit. _
_
") = vbYes Then
If MsgBox("Quell Diskette in Laufwerk A: einlegen", _
vbOKCancel + vbQuestion, " nur zur Sicherheit.") = vbOK Then
Else
Worksheets("Start").Activate
Exit Sub
End If
Else
Worksheets("Start").Activate
Exit Sub
End If
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'nur in Office Versionen ab 2007 nötig!
Workbooks.OpenText Filename:="A:\SAUEN.XLS", Origin:=xlWindows, StartRow _
:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _
Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, _
_
1), _
Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), _
Array( _
16, 4), Array(17, 4), Array(18, 4), Array(19, 4), Array(20, 4), Array(21, 4), Array(22, _
_
4), _
Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), Array(27, 1), Array(28, 1), _
Array( _
29, 1), Array(30, 1), Array(31, 1), Array(32, 1)), TrailingMinusNumbers:=True
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="A:\SAUEN.xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Application.DisplayAlerts = True
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Workbooks.Open("A:\Sauen.xlsx").Activate
Columns("A:AE").Select
Selection.Copy
Workbooks("Auswertung").Activate
Worksheets("Daten").Activate
ActiveSheet.Paste
Selection.Replace What:=",", Replacement:=".", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Dim lLetzte As Long ' die letzte belegte Zeile
Dim aVar() ' ein Array zur Datenaufnahme
Dim iIndx_1 As Integer ' Array-Index der 1. Dimension - Zeilen
Dim iIndx_2 As Integer ' Array-Index der 2. Dimension - Spalten
lLetzte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
aVar = Range("A1:AE" & lLetzte) ' die Daten an den Array übergeben
For iIndx_1 = 1 To lLetzte ' ab 1 bis zu letzten Zeile
For iIndx_2 = 1 To 5 ' ab Spalte 1 bis 5
If Not IsEmpty(aVar(iIndx_1, iIndx_2)) Then
If IsNumeric(aVar(iIndx_1, iIndx_2)) Then
aVar(iIndx_1, iIndx_2) = CDbl(aVar(iIndx_1, iIndx_2))
ElseIf IsDate(aVar(iIndx_1, iIndx_2)) Then
aVar(iIndx_1, iIndx_2) = CDate(aVar(iIndx_1, iIndx_2))
End If
End If
Next iIndx_2
Next iIndx_1
Range("A1:AE" & lLetzte) = aVar ' den Array zurückübertragen
Application.DisplayAlerts = False
Workbooks("Sauen.xlsx").Close
Application.DisplayAlerts = True
Worksheets("Daten").Visible = False
Worksheets("Start").Activate
'Änderungsdatum auslesen aus Sauen.xls
ActiveSheet.Unprotect Password:="*****"
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile("A:\Sauen.XLSX")
Worksheets("Start").Range("L4") = f.DateLastModified - 1 'Korrektur des Datums
ActiveSheet.Protect Password:="iland"
If MsgBox("Daten erfolgreich importiert", vbOKOnly) Then
Exit Sub
End If
'Exit Sub
Fehlerbehandlung:
If Err.Number = 1004 Then
If MsgBox("Quell Diskette in Laufwerk A:\ einlegen", _
vbOKCancel + vbQuestion, " nur zur Sicherheit.") = vbOK Then
GoTo noch_einmal:
End If
End If
Application.ScreenUpdating = True
End
Sub