Makro hängt sich auf :( - Bitte um Hilfe
25.07.2018 21:01:30
Friedrich
habe mir ein Makro mit verschieden Modulen gebaut. Habe jetzt die einzelnen Module getestet (im Einzelschritt) und alles funktioniert soweit einwandfrei. Möchte ich allerdings das ganze Makro ausführen, hängt sich Excel bzw. das Makro immer auf!
Bin über jeden Hinweis dankbar! :) Vielen Dank im Voraus.
Info: Die ganzen Variablen die "ein Buchstabe" sind, bestimmen nur die Zeilen oder die Tabellen bei denen das Makro jeweils sein soll. Haben keine höhere Relevanz. Die restlichen Variablen sollten durch den Namen etwas aussagekräftiger sein.
Hauptmodul:
Option Explicit
Public tabelle As Worksheet
Public zeile As Long
Public vergleichsdatum As Long
Public t As Integer
Sub neuedatenuebertragen()
'alte Daten aus der Datei löschen - Tabellenblatt löschen
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("COTdaten").Delete
Application.DisplayAlerts = True
'Daten aus der Quelldatei einfügen - über Makro Aufruf
Call dateneinfuegen
Dim iSpalte, anzahlzeilen, i, x As Integer
'neue Zeilen einfügen, Format übertragen und Zahlenreihe erneuern
With Application
.Calculation = xlManual
.ScreenUpdating = False
t = 2
For Each tabelle In ActiveWorkbook.Sheets
If tabelle.name "COTdaten" Then
x = 4
Call zeilenanzahl 'ermittelt die Zeile und das Datum
If zeile 0 Then
t = t + 1
While Cells(x, 2).Value Option Explicit
Sub dateneinfuegen()
Dim quelldatei, ursprungsdatei As Workbook
Dim nw, qw, zw As Worksheet
Dim strWindowName As String
Dim i As Integer
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.ShowWindowsInTaskbar = False
Workbooks.Open ("D:\Marktstrukturdaten\Daten")
strWindowName = ActiveWindow.Caption 'Fenstertitel in Variable einlesen
Windows(strWindowName).Visible = False 'Mappe ausblenden
Set quelldatei = Workbooks("Daten")
Set ursprungsdatei = Workbooks("COT Daten")
Set qw = quelldatei.Worksheets("XLS") 'Festlegung der Quelldatei
Set nw = ursprungsdatei.Sheets.Add(Before:=Worksheets(1)) 'Erstellung neues Tabellenblatts
nw.name = "COTdaten"
Set zw = ursprungsdatei.Sheets("COTdaten") 'Ziel zum kopieren
qw.Cells.Copy zw.Cells(1, 1)
Columns("B:B").Delete
Columns("C:C").Delete
Columns("D:D").Delete
Columns("C:C").Clear
Columns("D:D").Clear
For i = 1 To 7
Columns("F:F").Insert Shift:=xlToRight
Next i
Columns("O:O").Insert Shift:=xlToLeft
Columns("R:R").Clear
Columns("U:U").Clear
Columns("X:X").Clear
Columns("Y:Y").Delete
Columns("Y:Y").Delete
Columns("AA:GM").Clear
ErrorHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.ShowWindowsInTaskbar = True
Windows(strWindowName).Close SaveChanges:=False
End Sub
Option Explicit
Sub zeilenanzahl()
Dim suchbereich As Range
Dim suchbegriff As String
suchbegriff = Sheets(t).Cells(10, 1)
On Error Resume Next
Set suchbereich = Sheets("COTdaten").Range("A:A")
zeile = suchbereich.Find(What:=suchbegriff, MatchCase:=False, LookAt:=xlWhole).Row
If suchbereich Is Nothing Then 'Falls die Suche nichts findet = Abbruch
Exit Sub
End If
vergleichsdatum = Sheets("COTdaten").Cells(zeile, 2).Value
End Sub