Registriert seit: 10.04.2014
Version(en): 2016 + 365
27.06.2014, 00:03
(Dieser Beitrag wurde zuletzt bearbeitet: 27.06.2014, 00:04 von Rabe.)
Hi Alexandra,
(26.06.2014, 20:58)cysu11 schrieb: 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.
Registriert seit: 27.04.2014
Version(en): Privat: Office Home & Business 2019 / Arbeit: MS365
Hallo Ralf,
habe es ausprobiert, aber das Ergebnis ist das Gleiche!
Gibt es noch eine andere Möglichkeit?
Danke
VG
Alexandra
Registriert seit: 11.04.2014
Version(en): '97 bis 2016; 365
Hallo Alexandra,
Zitat:habe es ausprobiert, aber das Ergebnis ist das Gleiche!
Gibt es noch eine andere Möglichkeit?
.... wie hast Du es ausprobiert?
________________________________________________________________________
wer aufgibt, ohne es versucht zu haben, gibt einfach nur auf!
Grüße aus Norderstedt, Peter
Registriert seit: 27.04.2014
Version(en): Privat: Office Home & Business 2019 / Arbeit: MS365
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
Registriert seit: 27.04.2014
Version(en): Privat: Office Home & Business 2019 / Arbeit: MS365
Hallo Zusammen,
niemand eine Idee?
Vielen Dank
VG
Alexandra
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
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
Folgende(r) 1 Nutzer sagt Danke an Kuwer für diesen Beitrag:1 Nutzer sagt Danke an Kuwer für diesen Beitrag 28
• cysu11
Registriert seit: 27.04.2014
Version(en): Privat: Office Home & Business 2019 / Arbeit: MS365
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
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
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
Registriert seit: 27.04.2014
Version(en): Privat: Office Home & Business 2019 / Arbeit: MS365
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
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
Hallo Alexandra,
GetObject öffnet das Objekt grundsätzlich versteckt, was hier ein Vorteil ist.
Gruß Uwe
|