Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.04.2024 14:04:05
PDF per VBA ausgeben - Seitenskalierung
19.04.2024 13:58:02
Set Worksheet geht im O365 aber im Excel 2016 nicht
19.04.2024 13:49:38
Per Kopfdruck als pdf speichern und Mail erstellen
19.04.2024 12:58:59
Daten einfügen aus anderem Sheet
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1884to1888
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1884to1888
1884to1888
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Codeablauf hängt u. Excel reagiert nicht

Codeablauf hängt u. Excel reagiert nicht
18.05.2022 10:15:15
Florian
Hi Leute,
ich lasse diesen Code laufen, doch er hängt sich immer auf und Excel reagiert dann nicht mehr. Auch ein Abbruch des Codes mit ESC oder Pause ist nicht möglich.

Public Sub ImportDaten_2020()
Dim wksAbstimmung As Worksheet
Set wksAbstimmung = ThisWorkbook.Sheets("Abstimmung 2020")
ImportBuchungen
ImportSuSa
MsgBox "Die Daten wurden importiert und verarbeitet!", vbInformation, "Daten verarbeitet"
End Sub
Sub ImportSuSa()
Dim Dateiname
Dim WS As Worksheet
Dim intZeilen As Integer
Sheets("SuSa 2020").AutoFilterMode = False
Set WS = ThisWorkbook.Sheets("SuSa 2020")
Range("A1").Select
Dateiname = Application.GetOpenFilename(filefilter:="xls-Dateien (*.xls), *.*)", Title:="SuSa")
If Dateiname = "Falsch" Then
MsgBox "Keine Datei ausgewählt!"
Else
If Dateiname  False Then
'Application.ScreenUpdating = False
Workbooks.OpenText Filename:=Dateiname, Semicolon:=True
With ActiveSheet
intZeilen = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("A1:A" & intZeilen).Copy WS.Cells(1)
.Range("B1:B" & intZeilen).Copy WS.Cells(2)
.Range("C1:C" & intZeilen).Copy WS.Cells(3)
.Range("F1:F" & intZeilen).Copy WS.Cells(4)
.Range("G1:G" & intZeilen).Copy WS.Cells(5)
.Range("H1:H" & intZeilen).Copy WS.Cells(6)
End With
ActiveWorkbook.Close
'Application.ScreenUpdating = True
End If
End If
End Sub
Sub ImportBuchungen()
Dim Dateiname
Dim WS As Worksheet
Dim intZeilen As Integer
Dim lngZeileNaechste As Long
Dim lngZeileLetzte As Long
Dim wksTabelle As Worksheet
Sheets("Buchungen 2020").AutoFilterMode = False
Set WS = ThisWorkbook.Sheets("Buchungen 2020")
Range("A1").Select
Dateiname = Application.GetOpenFilename(filefilter:="xls-Dateien (*.xls), *.*)", Title:="Buchungen 2020")
If Dateiname = "Falsch" Then
MsgBox "Keine Datei ausgewählt!"
Else
If Dateiname  False Then
'Application.ScreenUpdating = False
Workbooks.OpenText Filename:=Dateiname, Semicolon:=True
lngZeileNaechste = 1
lngZeileLetzte = 0
For Each wksTabelle In ActiveWorkbook.Sheets
With wksTabelle
intZeilen = .Cells(Rows.Count, 1).End(xlUp).Row
lngZeileLetzte = lngZeileLetzte + intZeilen
.Range("A1:A" & intZeilen).Copy WS.Range("A" & lngZeileNaechste & ":A" & lngZeileLetzte)
.Range("C1:C" & intZeilen).Copy WS.Range("G" & lngZeileNaechste & ":G" & lngZeileLetzte)
.Range("D1:D" & intZeilen).Copy WS.Range("D" & lngZeileNaechste & ":D" & lngZeileLetzte)
.Range("E1:E" & intZeilen).Copy WS.Range("B" & lngZeileNaechste & ":B" & lngZeileLetzte)
.Range("G1:G" & intZeilen).Copy WS.Range("H" & lngZeileNaechste & ":H" & lngZeileLetzte)
.Range("H1:H" & intZeilen).Copy WS.Range("I" & lngZeileNaechste & ":I" & lngZeileLetzte)
.Range("J1:J" & intZeilen).Copy WS.Range("N" & lngZeileNaechste & ":N" & lngZeileLetzte)
WS.Range("F" & lngZeileNaechste & ":F" & lngZeileLetzte).Value = .Range("I3").Value
End With
lngZeileNaechste = lngZeileNaechste + intZeilen
Next wksTabelle
ActiveWorkbook.Close
'Application.ScreenUpdating = True
End If
End If
End Sub
Interessant ist, dass wenn ich ImportBuchungen und ImportSuSa einzeln laufen lassen alles funktioniert ohne Fehler. Wenn ich aber ImportDaten_2020 laufen lasse hängt er sich wohl nach dem ImportBuchungen auf.
Kann jemand erkennen, was das Problem sein könnte?
Danke euch!! :)

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Codeablauf hängt u. Excel reagiert nicht
18.05.2022 12:39:36
Tobias
Hallo Florian,
ohne viel zu testen, versuch mal bei beiden Prozeduren mit "Set WS = Nothing" am Ende deine Variablen wieder aufzuräumen. Könnte ein Problem sein.
Ansonsten mal im Einzelschritt durch die Prozedur gehen oder per Haltepunkte zumindest den Bereich genauer eingrenzen.
Schöne Grüße
Tobias
AW: Codeablauf hängt u. Excel reagiert nicht
18.05.2022 13:46:49
Florian
Ich hab mal in dieser Zeile in ImportBuchungen einen Haltepunkt gesetzt und bin dann im Einzelschritt durch den weiteren Code:

ActiveWorkbook.Close
Wenn ich dann in den VBA-Editor wechsle und dort mit der Maus klicke, reagiert Excel zunächst nicht. Erst nach ein paar Klick werden meine Klicks angenommen und ich kann den Code weiterlaufen ohne Probleme.
Das hilft mir jedoch beim Durchlauf ohne Haltepunkt nichts, das es dann einfach nicht weitergeht, auch wenn ich mehrere Minuten warte.
Kanne s daran liegen, dass die Mappe, die ich öffne, mehr als 100 Tabellen hat, die ich durchlaufe?
Was könnte ich nocht testen? Hat jemand noch eine Idee?
Anzeige
AW: Codeablauf hängt u. Excel reagiert nicht
18.05.2022 15:09:38
peterk
Hallo
Ich würde in die Schleife ein DoEvents() einfügen, dann kannst Du zumindest mit ESC in den Debug Modus gelangen .
Peter
AW: Codeablauf hängt u. Excel reagiert nicht
18.05.2022 14:34:03
Rudi
Hallo,
erst mal die üblichen Beschleuniger:

Public Sub ImportDaten_2020()
Dim wksAbstimmung As Worksheet  'wozu?
Set wksAbstimmung = ThisWorkbook.Sheets("Abstimmung 2020")  'wozu?
Call GetMoreSpeed(True)
ImportBuchungen
ImportSuSa
Call GetMoreSpeed(False)
MsgBox "Die Daten wurden importiert und verarbeitet!", vbInformation, "Daten verarbeitet"
End Sub
Sub GetMoreSpeed(Optional ByVal Modus As Boolean = True)
With Application
.ScreenUpdating = Not Modus
.EnableEvents = Not Modus
.Calculation = IIf(Modus = True, xlManual, xlAutomatic)
.Cursor = IIf(Modus = True, 2, -4143)
End With
End Sub
Warum öffnest du die Dateien mit OpenText statt mit Workbooks.Open?
100 Tabellen sind natürlich ne Macht. Da sollte man sich was anderes überlegen statt Zellen zu kopieren. Evtl. erst alles in Arrays sammeln.
Gruß
Rudi
Anzeige
AW: Codeablauf hängt u. Excel reagiert nicht
18.05.2022 15:51:57
Rudi
probier das mal:

Sub ImportBuchungen()
Dim Dateiname
Dim wkbIMPORT As Workbook
Dim WS As Worksheet
Dim lngZeilen As Long
Dim lngZeileNaechste As Long
Dim lngZeileLetzte As Long
Dim wksTabelle As Worksheet
Dim objOUT(1 To 8), arrTmp, i As Long
For i = 1 To 8
Set objOUT(i) = CreateObject("scripting.dictionary")
Next
'  Set WS = ThisWorkbook.Sheets("Buchungen 2020")
'  If WS.FilterMode Then WS.ShowAllData
'  Range("A1").Select
Dateiname = Application.GetOpenFilename(filefilter:="xls-Dateien (*.xls*), *.*)", Title:="Buchungen 2020")
If Dateiname = "Falsch" Then
MsgBox "Keine Datei ausgewählt!"
Else
Set wkbIMPORT = Workbooks.Open(Filename:=Dateiname)
lngZeileNaechste = 1
lngZeileLetzte = 0
For Each wksTabelle In wkbIMPORT.Worksheets
With wksTabelle
lngZeilen = .Cells(.Rows.Count, 1).End(xlUp).Row
arrTmp = .Cells(1, 1).Resize(lngZeilen, 10)
For i = 1 To lngZeilen
objOUT(1)(objOUT(1).Count + 1) = arrTmp(i, 1)
objOUT(2)(objOUT(2).Count + 1) = arrTmp(i, 3)
objOUT(3)(objOUT(3).Count + 1) = arrTmp(i, 4)
objOUT(4)(objOUT(4).Count + 1) = arrTmp(i, 5)
objOUT(5)(objOUT(5).Count + 1) = arrTmp(i, 7)
objOUT(6)(objOUT(6).Count + 1) = arrTmp(i, 8)
objOUT(7)(objOUT(7).Count + 1) = arrTmp(i, 10)
objOUT(8)(objOUT(8).Count + 1) = arrTmp(3, 9)
Next i
'        lngZeileLetzte = lngZeileLetzte + lngZeilen
'        .Range("A1:A" & lngZeilen).Copy WS.Range("A" & lngZeileNaechste & ":A" & lngZeileLetzte)
'        .Range("C1:C" & lngZeilen).Copy WS.Range("G" & lngZeileNaechste & ":G" & lngZeileLetzte)
'        .Range("D1:D" & lngZeilen).Copy WS.Range("D" & lngZeileNaechste & ":D" & lngZeileLetzte)
'        .Range("E1:E" & lngZeilen).Copy WS.Range("B" & lngZeileNaechste & ":B" & lngZeileLetzte)
'        .Range("G1:G" & lngZeilen).Copy WS.Range("H" & lngZeileNaechste & ":H" & lngZeileLetzte)
'        .Range("H1:H" & lngZeilen).Copy WS.Range("I" & lngZeileNaechste & ":I" & lngZeileLetzte)
'        .Range("J1:J" & lngZeilen).Copy WS.Range("N" & lngZeileNaechste & ":N" & lngZeileLetzte)
'        WS.Range("F" & lngZeileNaechste & ":F" & lngZeileLetzte).Value = .Range("I3").Value
End With
'      lngZeileNaechste = lngZeileNaechste + lngZeilen
Next wksTabelle
With WS
.Cells(1, 1).Resize(objOUT(1).Count) = Application.Transpose(objOUT(1).items)
.Cells(1, 7).Resize(objOUT(2).Count) = Application.Transpose(objOUT(2).items)
.Cells(1, 4).Resize(objOUT(3).Count) = Application.Transpose(objOUT(3).items)
.Cells(1, 2).Resize(objOUT(4).Count) = Application.Transpose(objOUT(4).items)
.Cells(1, 8).Resize(objOUT(5).Count) = Application.Transpose(objOUT(5).items)
.Cells(1, 9).Resize(objOUT(6).Count) = Application.Transpose(objOUT(6).items)
.Cells(1, 14).Resize(objOUT(7).Count) = Application.Transpose(objOUT(7).items)
.Cells(1, 6).Resize(objOUT(8).Count) = Application.Transpose(objOUT(8).items)
End With
wkbIMPORT.Close False
End If
End Sub
Gruß
Rudi
Anzeige
Korrektur
18.05.2022 16:42:26
Rudi 

Option Explicit
Sub ImportBuchungen()
Dim Dateiname
Dim wkbIMPORT As Workbook
Dim WS As Worksheet
Dim lngZeilen As Long
Dim lngZeileNaechste As Long
Dim lngZeileLetzte As Long
Dim wksTabelle As Worksheet
Dim objOUT(1 To 8), arrTmp, i As Long
For i = 1 To 8
Set objOUT(i) = CreateObject("scripting.dictionary")
Next
Set WS = ThisWorkbook.Sheets("Buchungen 2020")
If WS.FilterMode Then WS.ShowAllData
Range("A1").Select
Dateiname = Application.GetOpenFilename(filefilter:="xls-Dateien (*.xls*), *.*)", Title:="Buchungen 2020")
If Dateiname = "Falsch" Then
MsgBox "Keine Datei ausgewählt!"
Else
Set wkbIMPORT = Workbooks.Open(Filename:=Dateiname)
lngZeileNaechste = 1
lngZeileLetzte = 0
For Each wksTabelle In wkbIMPORT.Worksheets
With wksTabelle
lngZeilen = .Cells(.Rows.Count, 1).End(xlUp).Row
arrTmp = .Cells(1, 1).Resize(lngZeilen, 10)
For i = 1 To lngZeilen
objOUT(1)(objOUT(1).Count + 1) = arrTmp(i, 1)
objOUT(2)(objOUT(2).Count + 1) = arrTmp(i, 3)
objOUT(3)(objOUT(3).Count + 1) = arrTmp(i, 4)
objOUT(4)(objOUT(4).Count + 1) = arrTmp(i, 5)
objOUT(5)(objOUT(5).Count + 1) = arrTmp(i, 7)
objOUT(6)(objOUT(6).Count + 1) = arrTmp(i, 8)
objOUT(7)(objOUT(7).Count + 1) = arrTmp(i, 10)
objOUT(8)(objOUT(8).Count + 1) = arrTmp(3, 9)
Next i
'        lngZeileLetzte = lngZeileLetzte + lngZeilen
'        .Range("A1:A" & lngZeilen).Copy WS.Range("A" & lngZeileNaechste & ":A" & lngZeileLetzte)
'        .Range("C1:C" & lngZeilen).Copy WS.Range("G" & lngZeileNaechste & ":G" & lngZeileLetzte)
'        .Range("D1:D" & lngZeilen).Copy WS.Range("D" & lngZeileNaechste & ":D" & lngZeileLetzte)
'        .Range("E1:E" & lngZeilen).Copy WS.Range("B" & lngZeileNaechste & ":B" & lngZeileLetzte)
'        .Range("G1:G" & lngZeilen).Copy WS.Range("H" & lngZeileNaechste & ":H" & lngZeileLetzte)
'        .Range("H1:H" & lngZeilen).Copy WS.Range("I" & lngZeileNaechste & ":I" & lngZeileLetzte)
'        .Range("J1:J" & lngZeilen).Copy WS.Range("N" & lngZeileNaechste & ":N" & lngZeileLetzte)
'        WS.Range("F" & lngZeileNaechste & ":F" & lngZeileLetzte).Value = .Range("I3").Value
End With
'      lngZeileNaechste = lngZeileNaechste + lngZeilen
Next wksTabelle
With WS
.Cells(1, 1).Resize(objOUT(1).Count) = Application.Transpose(objOUT(1).items)
.Cells(1, 7).Resize(objOUT(2).Count) = Application.Transpose(objOUT(2).items)
.Cells(1, 4).Resize(objOUT(3).Count) = Application.Transpose(objOUT(3).items)
.Cells(1, 2).Resize(objOUT(4).Count) = Application.Transpose(objOUT(4).items)
.Cells(1, 8).Resize(objOUT(5).Count) = Application.Transpose(objOUT(5).items)
.Cells(1, 9).Resize(objOUT(6).Count) = Application.Transpose(objOUT(6).items)
.Cells(1, 14).Resize(objOUT(7).Count) = Application.Transpose(objOUT(7).items)
.Cells(1, 6).Resize(objOUT(8).Count) = Application.Transpose(objOUT(8).items)
End With
wkbIMPORT.Close False
End If
End Sub
da war noch was auskommentiert.
Läuft bei mir mit 160 Worksheets &lt 2 Sekunden
Gruß
Rudi
Anzeige
AW: Korrektur
20.05.2022 10:00:33
Florian
Läuft prima, danke.
Allerdings dauert es bei mir 4 Sekunden mit 126 Tabellen :D

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige