Prüfung ob Datei bereits offen!

[Rabe]

Hi Alexandra,

Gibt es eine Möglichkeit, dass das alles im Hintergrund passiert, so dass man das alles nicht sieht?

spiel mal mit "Application.ScreenUpdating = False" am Anfang und True am Ende des Codes rum.

Das schaltet die Bildschirmaktualisierung aus und mit True wieder ein.

[cysu11]

Hallo Ralf,


habe es ausprobiert, aber das Ergebnis ist das Gleiche!
Gibt es noch eine andere Möglichkeit?


Danke
VG
Alexandra

[Käpt'n Blaubär]

Hallo Alexandra,

habe es ausprobiert, aber das Ergebnis ist das Gleiche!
Gibt es noch eine andere Möglichkeit?

.... wie hast Du es ausprobiert?

[cysu11]

Hallo Peter,


wie folgt:

Code:

Public Sub cmdLöschen_Click()
Application.ScreenUpdating = False
    Dim var
   Dim rngLoeschWert As Range
   'falls aus der Listbox kein Element gewählt ist verlasse die Sub
   If lstAttribute.ListIndex = -1 Then
       MsgBox "Bitte Attribut auswählen!"
   Exit Sub
   End If
    var = MsgBox("Sind Sie sicher, dass Sie den Begriff " & lstAttribute.Value & " aus der Kategorie " & " " & ComboBox1.Value & " " & "löschen möchten? ", vbYesNo)
     If var = 7 Then
         Exit Sub
         Else
            If PrüfungDateiOffen Then Exit Sub
   Set DB = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & "DB.xlsm", ReadOnly:=False, Password:="", WriteResPassword:="")
      'suchen des Wertes in der betreffenden Spalte
   Set rngLoeschWert = DB.Worksheets("Attribute").Columns(rngUberschriften.Column).Find(lstAttribute.Value, LookIn:=xlValues, lookat:=xlWhole)
   If Not rngLoeschWert Is Nothing Then
      'und lösche ihn und schiebe die weiteren nach oben
      rngLoeschWert.Delete xlShiftUp
   End If
   End If
    lstAttribute.RemoveItem lstAttribute.ListIndex
    DB.Close SaveChanges:=True
        Datensync
        'LiveSync
    ThisWorkbook.Save
    Application.ScreenUpdating = True

End Sub

Code:

Sub Datensync()
Dim Quelldateiname  As String
Dim Quelle      As Object
Dim wsZiel1 As Worksheet
Dim wsZiel2 As Worksheet
Dim wsZiel3 As Worksheet
Dim wsZiel4 As Worksheet
Dim wsZiel5 As Worksheet
Dim wsZiel6 As Worksheet

Dim wsQuelle1 As Worksheet
Dim wsQuelle2 As Worksheet
Dim wsQuelle3 As Worksheet
Dim wsQuelle4 As Worksheet
Dim wsQuelle5 As Worksheet
Dim wsQuelle6 As Worksheet
Application.ScreenUpdating = False

  
   Quelldateiname = ThisWorkbook.Path & "\" & "DB.xlxm" ' Datei auswählen
  
   'Set Quelle = Workbooks("DB.xlsm") 'Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & "DB.xlsm", ReadOnly:=True, Password:="", WriteResPassword:="") ' Datei öffnen
    Set Quelle = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & "DB.xlsm", ReadOnly:=True, Password:="", WriteResPassword:="") ' Datei öffnen

    Set wsZiel1 = ThisWorkbook.Sheets("produkte")
        wsZiel1.Cells.ClearContents
        wsZiel1.Cells.ClearFormats
    Set wsQuelle1 = Quelle.Worksheets("produkte")
    wsQuelle1.Cells.Copy Destination:=ThisWorkbook.Sheets("produkte").Cells
    
    Set wsZiel2 = ThisWorkbook.Sheets("kunden")
        wsZiel2.Cells.ClearContents
        wsZiel2.Cells.ClearFormats
    Set wsQuelle2 = Quelle.Worksheets("kunden")
    wsQuelle2.Cells.Copy Destination:=ThisWorkbook.Sheets("kunden").Cells
    
    Set wsZiel3 = ThisWorkbook.Sheets("LNA")
        wsZiel3.Cells.ClearContents
        wsZiel3.Cells.ClearFormats
    Set wsQuelle3 = Quelle.Worksheets("LNA")
    wsQuelle3.Cells.Copy Destination:=ThisWorkbook.Sheets("LNA").Cells
    
    Set wsZiel4 = ThisWorkbook.Sheets("zwischen")
        wsZiel4.Cells.ClearContents
        wsZiel4.Cells.ClearFormats
    Set wsQuelle4 = Quelle.Worksheets("zwischen")
    wsQuelle4.Cells.Copy Destination:=ThisWorkbook.Sheets("zwischen").Cells
    
    Set wsZiel5 = ThisWorkbook.Sheets("Attribute")
        wsZiel5.Cells.ClearContents
        wsZiel5.Cells.ClearFormats
    Set wsQuelle5 = Quelle.Worksheets("Attribute")
    wsQuelle5.Cells.Copy Destination:=ThisWorkbook.Sheets("Attribute").Cells
    
    Set wsZiel6 = ThisWorkbook.Sheets("LNK")
        wsZiel6.Cells.ClearContents
        wsZiel6.Cells.ClearFormats
    Set wsQuelle6 = Quelle.Worksheets("LNK")
    wsQuelle6.Cells.Copy Destination:=ThisWorkbook.Sheets("LNK").Cells
      
    Quelle.Close SaveChanges:=False

    Set wsQuelle1 = Nothing
    Set wsQuelle2 = Nothing
    Set wsQuelle3 = Nothing
    Set wsQuelle4 = Nothing
    Set wsQuelle5 = Nothing
    Set wsQuelle6 = Nothing

    Set wsZiel1 = Nothing
    Set wsZiel2 = Nothing
    Set wsZiel3 = Nothing
    Set wsZiel4 = Nothing
    Set wsZiel5 = Nothing
    Set wsZiel6 = Nothing
    Application.ScreenUpdating = True

    ThisWorkbook.Save
End Sub

Oder habe ich das verkehrt eingetragen!?


Vielen Dank
VG
Alexandra

[cysu11]

Hallo Zusammen,


niemand eine Idee?


Vielen Dank
VG
Alexandra

[Kuwer]

Hallo Alexandra,

die extra Sub "Datensync" kannst Du löschen.
Das sieht zwar mächtig gewaltig aus, aber außer vieler unnötiger Variablen
und einer nochmaligen Öffnung der gerade eben geöffneten und wieder geschlossenen Quellmappe
bringt sie m.E. keinen Mehrwert.

Teste mal so:

Code:

Public Sub cmdLöschen_Click()
  Dim rngLoeschWert As Range
  Dim wbQuelle As Workbook
  Dim wsZiel As Worksheet
  'falls aus der Listbox kein Element gewählt ist verlasse die Sub
  If lstAttribute.ListIndex = -1 Then
     MsgBox "Bitte Attribut auswählen!"
     Exit Sub
  End If
  If MsgBox("Sind Sie sicher, dass Sie den Begriff " & lstAttribute.Value & " aus der Kategorie " & " " & ComboBox1.Value & " " & "löschen möchten? ", vbYesNo) = vbYes Then
    If PrüfungDateiOffen Then Exit Sub
    Application.ScreenUpdating = False
    Set wbQuelle = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & "DB.xlsm", ReadOnly:=False, Password:="", WriteResPassword:="")
      'suchen des Wertes in der betreffenden Spalte
    Set rngLoeschWert = wbQuelle.Worksheets("Attribute").Columns(rngUberschriften.Column).Find(lstAttribute.Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not rngLoeschWert Is Nothing Then
      'und lösche ihn und schiebe die weiteren nach oben
      rngLoeschWert.Delete xlShiftUp
    End If
    lstAttribute.RemoveItem lstAttribute.ListIndex
    For Each wsZiel In ThisWorkbook.Sheets(Array("produkte", "kunden", "LNA", "zwischen", "Attribute", "LNK"))
      wsZiel.Cells.ClearContents
      wsZiel.Cells.ClearFormats
      wbQuelle.Worksheets(wsZiel.Name).Cells.Copy Destination:=wsZiel.Cells
    Next wsZiel
    wbQuelle.Close SaveChanges:=True
    ThisWorkbook.Save
    Application.ScreenUpdating = True
  End If
End Sub

Gruß Uwe

[cysu11]

Hallo Uwe,


vielen Dank für deine Hilfe! Der Code funktioniert in der Tat schneller wie meiner und ich sehe die DB-Datei nicht mehr in Hintergrund öffnen, allerdings verschwindet meine Userform immer noch kurz und ich sehe die Tabelle in Hintergrund! :@

Hast du noch eine Idee?

Habe mir schon überlegt, einer "Fortschrittsbalken" einzubauen um das Ganze zu verschönern! :s


Vielen Dank im Voraus
VG
Alexandra

[Kuwer]

Hallo Alexandra,

ich kann zwar nicht nachvollziehen, warum es da flackert,
aber Du kannst mal folgendes testen:

Ersetze die Zeile

Code:

Set wbQuelle = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & "DB.xlsm", ReadOnly:=False, Password:="", WriteResPassword:="")

durch

Code:

Set wbQuelle = GetObject(ThisWorkbook.Path & "\DB.xlsm")

Gruß Uwe

[cysu11]

Hallo Uwe,


wow, viel besser! Jetzt wird der Bildschirm nur noch kurz weiß aber von der Datei DB.xlsm nichts mehr zu sehen! :)

Damit kann ich glaube ich leben!

Wo ist der Unterschied Vor- und Nachteile zwischen den zwei Codes:

workbooks.open
und
getobject


Vielen Dank
VG
Alexandra

[Kuwer]

Hallo Alexandra,

GetObject öffnet das Objekt grundsätzlich versteckt, was hier ein Vorteil ist.

Gruß Uwe