AW: Makro stoppt nach Workbooks.Open Filename:=datei
27.01.2005 17:35:19
Marius
hmm, nein, hat leider nichts gebracht, hier mal der aktuelle Code:
Sub Test()
' Tastenkombination: Strg+Umschalt+T
'Variablen
Dim wert1 As Long, wert2 As Long, activerow As Integer
'Auswahl der zu uebertragenden Evals
titel1 = "Startwert"
mldg1 = "Geben Sie bitte die KENNUMMER der ERSTEN einzulesenden Evaluation an"
titel2 = "Endwert"
mldg2 = "Geben Sie bitte die KENNUMMER der LETZTEN einzulesenden Evaluation"
wert1 = InputBox(mldg1, titel1, , 100, 100)
wert2 = InputBox(mldg2, titel2, , 100, 100)
'Finden des Speicherpfades
Dim wkb1, wbk2 As Workbook
pfad = ActiveWorkbook.Path & "\"
'aktuell = ActiveWorkbook.Name
Set wbk1 = ActiveWorkbook
aktuell = wbk1.Name
'Finden der ersten freien Zeile (row)
activerow = Cells(Rows.Count, 1).End(xlUp).Row + 1
'Beginn der Schleife für alle Evals
Do While wert1 <= wert2
'Zusammenbau der EvalA Kennnummer
If wert1 > 999 Then Dateiname = "EvalA_" & LTrim(Str(wert1)) & ".xls" Else If wert1 > 99 Then Dateiname = "EvalA_0" & LTrim(Str(wert1)) & ".xls" Else If wert1 > 9 Then Dateiname = "EvalA_00" & LTrim(Str(wert1)) & ".xls" Else: Dateiname = "EvalA_000" & LTrim(Str(wert1)) & ".xls"
datei = pfad & Dateiname
'Auslesen der Werte in EvalA Datei
errmsg = "Die Datei" & Dateiname & "wurde nicht gefunden"
If Dir(datei) <> "" Then Workbooks.Open Filename:=datei: Set wbk2 = ActiveWorkbook Else MsgBox errmsg: GoTo loopbr
site = Cells(11, 2).Value
prodgr = Cells(11, 5).Value
assdate = Cells(14, 1).Value
country = Cells(14, 2).Value
dqsoff = Cells(14, 3).Value
ref = Cells(14, 4).Value
standard = Cells(14, 5).Value
auditor1 = Cells(17, 5).Value
auditor2 = Cells(17, 6).Value
wbk2.Close
'Workbooks(Dateiname).Close
'Eintragen der Werte in Liste der Evals
'Set aktuell = ActiveWorkbook
wbk1.Activate
Cells(activerow, 1) = auditor1
Cells(activerow, 2) = "AL"
Cells(activerow, 3) = site
Cells(activerow, 4) = prodgr
Cells(activerow, 5) = assdate
Cells(activerow, 6) = country
Cells(activerow, 7) = dqsoff
Cells(activerow, 8) = ref
Cells(activerow, 9) = standard
If auditor2 <> "" Then
activerow = activerow + 1
Cells(activerow, 1) = auditor2
Cells(activerow, 2) = "Co"
Cells(activerow, 3) = site
Cells(activerow, 4) = prodgr
Cells(activerow, 5) = assdate
Cells(activerow, 6) = country
Cells(activerow, 7) = dqsoff
Cells(activerow, 8) = ref
Cells(activerow, 9) = standard
End If
activerow = activerow + 1
loopbr:
wert1 = wert1 + 1
Loop
Cells(activerow, 1).Activate
mldg1 = "Die Evaluationswerte wurden der Tabelle hinzugefügt"
titel1 = "Aktion erfolgreich"
MsgBox mldg1, , titel1
End Sub