makrorecorder - elegantere lösung?
08.06.2014 01:32:40
Spenski
habe eine datei auf. über button öffne ich eine andere datei (schreibschutz) , kopier den kompletten inhalt.
dann geh ich wieder zurück in meine ursprungsdatei und füge den inhalt in tabelle1 ein.
das klappt auch soweit. hab nur einen teil mit makro recorder aufgenommen und wollt fragen wie ichs am besten (das es so schnell wie möglich läuft) schreiben kann
hier der code...um den fetten/cursiven teil geht es:
Sub a()
Dim sPath$, nReturn%, iTimer%
Const ObenKennwort$ = "MD" 'passwort ändern
Const SchreibLeseKennwort$ = "MD" 'passwort ändern
iTimer = 10
sPath = "C:\Users\Spenski\Desktop\MD.xlsx" 'pfad ändern
nReturn = TestOpen(sPath)
Do While nReturn 0
If nReturn = 2 Then
Exit Do
End If
If iTimer = 0 Then Exit Do
Application.Wait Now + TimeSerial(0, 0, 1)
DoEvents
iTimer = iTimer - 1
nReturn = TestOpen(sPath)
Loop
If nReturn = 0 Then
Application.DisplayAlerts = False
With Workbooks.Open(sPath, ReadOnly:=False, Password:=ObenKennwort, WriteResPassword:= _
SchreibLeseKennwort, IgnoreReadOnlyRecommended:=True)
If .ReadOnly = False Then
With .Sheets("Datenbank")
Cells.Select
Selection.Copy
Windows("Lagertool.xlsm").Activate
Sheets("Tabelle1").Select
Cells.Select
ActiveSheet.Paste
Sheets("Lagertool").Select
End With
.Close True
Else
.Close False
MsgBox "Die Datei ist Schreibgeschützt, versuchen sie es noch einmal!" 'text ä _
ndern?
End If
End With
Application.DisplayAlerts = True
ElseIf nReturn = 2 Then
MsgBox "Zieldatei nicht gefunden. Bitte Info an KPM Coach!" 'text ändern?
ElseIf nReturn = 1 Then
MsgBox "Die Datei ist Schreibgeschützt, versuchen sie es noch einmal!" 'text ändern?
Exit Sub
End If
End Sub
Function TestOpen(sFile As String) As Integer
If Dir(sFile, vbNormal) = "" Then
TestOpen = 2
Else
On Error GoTo ERRORHANDLER
Open sFile For Random Access Read Lock Read Write As #99
Close #99
End If
ERRORHANDLER:
If Err.Number = 70 Then TestOpen = 1
End Function