Laufzeitfehler verhindert Öffnen der Excel Datei
Eva
habe ein komisches Problem mit dem unten aufgeführten Makro - Schon beim Öffnen des Excel Sheets wird nach ewiger Zeit ein Fehler angezeigt, obwohl es anfänglich funktionierte(?).
Kann mir jemand bitte helfen.
Mit Dank, Eva
Private Sub btnHead_Click()
Dim ws As Workbook
Dim sheet As Worksheet
Dim wksKst As Worksheet
Dim wb As Workbook
Set wksKst = ActiveWorkbook.Worksheets("Kst_Zuordnung")
pfad = "E:\90_trainee_students\Meixner\Februar bis Mai 2004\Plan HC_Excel\3_Personalkostenplanung\"
dateiname = "Testversion_Personalkostenplanung GJ 04-05.xls"
headsheet = "HC-Plan"
If checkOpen(dateiname) = False Then
Set ws = Application.Workbooks.Open(pfad & dateiname, False)
Else
Set ws = Workbooks(dateiname)
End If
Set sheet = ws.Worksheets(headsheet)
zeile = 8
spalte = 1
kst = ComboBox1.Value
zielzeile = findeZeile(kst, sheet)
zielspalte = 3
Do
If Not IsEmpty(wksKst.Cells(zeile, spalte + 1)) Then
For i = spalte + 3 To spalte + 3 + 12
sheet.Cells(zielzeile, zielspalte + i - 4) = wksKst.Cells(zeile, i).Value
Next i
zielzeile = zielzeile + 1
End If
zeile = zeile + 1
Loop Until IsEmpty(sheet.Cells(zeile, spalte + 1))
End Sub
Function checkOpen(dateiname)
Dim wb As Workbook
For Each wb In Workbooks
If wb.Name = dateiname Then
checkOpen = True
Exit Function
End If
Next
checkOpen = False
End Function
Function findeZeile(kst, sheet As Worksheet)
zeile = 3
spalte = 2
Do
If LTrim(Str(sheet.Cells(zeile, spalte - 1))) = kst Then
findeZeile = zeile
Exit Function
End If
zeile = zeile + 1
Loop Until IsEmpty(sheet.Cells(zeile, spalte))
End Function
Private Sub ComboBox1_Change()
fuellen
End Sub
Private Sub fuellen()
Dim wksUeb As Worksheet, wksKst As Worksheet
Set wksUeb = ActiveWorkbook.Worksheets("Übersetzer für HC-Report")
Set wksKst = ActiveWorkbook.Worksheets("Kst_Zuordnung")
z = 3
kst = ComboBox1.Value
Do Until wksUeb.Cells(z, 1) = "Ges"
If wksUeb.Cells(z, 1) = kst Then
For s = 3 To 33
If s = 28 Then wksKst.Cells(8, 3) = wksUeb.Cells(z, s)
If s = 27 Then wksKst.Cells(9, 3) = wksUeb.Cells(z, s)
If s = 26 Then wksKst.Cells(10, 3) = wksUeb.Cells(z, s)
If s = 33 Then wksKst.Cells(11, 3) = wksUeb.Cells(z, s)
If s = 32 Then wksKst.Cells(12, 3) = wksUeb.Cells(z, s)
If s = 31 Then wksKst.Cells(13, 3) = wksUeb.Cells(z, s)
If s = 30 Then wksKst.Cells(14, 3) = wksUeb.Cells(z, s)
If s = 11 Then wksKst.Cells(19, 3) = wksUeb.Cells(z, s)
If s = 10 Then wksKst.Cells(20, 3) = wksUeb.Cells(z, s)
If s = 9 Then wksKst.Cells(21, 3) = wksUeb.Cells(z, s)
If s = 7 Then wksKst.Cells(24, 3) = wksUeb.Cells(z, s)
If s = 6 Then wksKst.Cells(25, 3) = wksUeb.Cells(z, s)
If s = 4 Then wksKst.Cells(26, 3) = wksUeb.Cells(z, s)
If s = 5 Then wksKst.Cells(27, 3) = wksUeb.Cells(z, s)
If s = 3 Then wksKst.Cells(28, 3) = wksUeb.Cells(z, s)
If s = 8 Then wksKst.Cells(29, 3) = wksUeb.Cells(z, s)
If s = 24 Then wksKst.Cells(15, 3) = wksUeb.Cells(z, s)
If s = 25 Then wksKst.Cells(16, 3) = wksUeb.Cells(z, s)
Next s
End If
z = z + 1
Loop
End Sub
Anzeige