Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

makrorecorder - elegantere lösung?

Betrifft: makrorecorder - elegantere lösung? von: Spenski
Geschrieben am: 08.06.2014 01:32:40

hi

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

  

Betrifft: AW: makrorecorder - elegantere lösung? von: Crazy Tom
Geschrieben am: 08.06.2014 07:07:10

Hallo Christian

so hab ich es bei mir ans laufen bekommen

    Cells.Copy Destination:=ThisWorkbook.Sheets("Tabelle1").Range("A1")
    ThisWorkbook.Activate
    ThisWorkbook.Sheets("Lagertool").Select
MfG Tom


  

Betrifft: AW: makrorecorder - elegantere lösung? von: Spenski
Geschrieben am: 08.06.2014 08:28:15

frohe pfingsten tom
läuft super. meins lief zwar auch aber es ist deutlich zu sehen das im hintergrund weniger gearbeitet wird. auch wenns nur millisekundenn sind.

danke


  

Betrifft: AW: makrorecorder - elegantere lösung? von: fcs
Geschrieben am: 08.06.2014 09:24:50

Hallo Spenski,

man kann siche einige Selects und Aktivates sparen.

Warum öffnest du die Datei MD.xlsx nicht einfach schreibgeschütz und schließt sie nach dem Kopieren der Daten ohne speichern wieder??

Oder finden da via Formeln noch Aktualisierungen zwischen den beiden Dateien statt, so dass das Speichern erforderlich ist?

Gruß
Franz

Sub a()
  Dim sPath$, nReturn%, iTimer%
  Dim wksZiel As Worksheet, rngCopy As Range, StatusCalc As Long
 
  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
    With Application
      .DisplayAlerts = False
      .ScreenUpdating = False
      .Calculation = xlCalculationManual
    End With
    
    Set wksZiel = ActiveWorkbook.Worksheets("Tabelle1")
    wksZiel.UsedRange.EntireColumn.Clear
    
    'Datei könnte man ggf. auch schreibgeschützt öffnen und dann ohne Speichern _
        wieder schliessen
    With Workbooks.Open(sPath, ReadOnly:=False, Password:=ObenKennwort, _
        WriteResPassword:=SchreibLeseKennwort, IgnoreReadOnlyRecommended:=True)
      If .ReadOnly = False Then
        Application.Calculate 'nur erforderlich wenn Berechnungen vor dem Kopieren _
          aktualisiert werden müssen.
        With .Sheets("Datenbank")
            Set rngCopy = .UsedRange.EntireColumn
            rngCopy.Copy Destination:=wksZiel.Range(rngCopy.Address)
        End With
        .Close True             'Warum nach dem Kopieren der Daten Datei speichern??
      Else
        .Close False
        MsgBox "Die Datei ist Schreibgeschützt, versuchen sie es noch einmal!" 'text _
          ändern?
      End If
    End With
    
    With Application
      .DisplayAlerts = True
      .ScreenUpdating = True
      .Calculation = StatusCalc
    End With
  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                                    'überflüssige Zeile
  End If
End Sub

Function TestOpen(sFile As String) As Integer
    Dim FF As Integer
    If Dir(sFile, vbNormal) = "" Then
        TestOpen = 2
    Else
        
        On Error GoTo ERRORHANDLER
        FF = FreeFile
        Open sFile For Random Access Read Lock Read Write As #FF
        Close #FF
  
    End If
ERRORHANDLER:
    If Err.Number = 70 Then TestOpen = 1
End Function



  

Betrifft: AW: makrorecorder - elegantere lösung? von: Spenski
Geschrieben am: 08.06.2014 11:07:16

hallo franz
wie man sieht bastel ich aus verhandenen codes irgendwas zusammen damit es einigermaßen läuft.
ich verstehe die codes auch nur ca zu 20% aber ich versuche sie nach und nach zu verstehen indem ich damit arbeite. hab in die richutung auch nix gelernt.

in diesem fall würde es echt reichen die datein schreibgeschützt zu öffnen, kopieren in zieldatei einfügen und wieder schliessen ohne zu speichern.

hatte den obrigen code genommen da ich wusste das er funktioniert und was ich ändern muss. aber ich schau mal ob ich was anderes finde

danke
christian


 

Beiträge aus den Excel-Beispielen zum Thema "makrorecorder - elegantere lösung?"