Hallo zusammen,
habe hier große Probleme mit einem Makro was unter Win NT und Office97 problemlos läuft, unter Win XP und Office XP ab Spalte 200 nur noch im Schneckentempo arbeitet.
Hintergrund:
Es werden aus Tabelle A ca. 1400 Datensätze mit denen in Tabelle B abgeglichen. Neue werden Grün markiert, die die wegfallen Rot.
Auszug aus dem VBA-Code:
Public Sub KatalogAbgleichen()
On Error GoTo Err_Sub
Dim c As Range
Dim intCounter As Integer
Dim intZeileRotEnde As Integer
Dim intZeileGruenStart As Integer
Dim intZeileGruenEnde As Integer
Dim intEnde As Integer
Dim intAnzahlRot As Integer
Dim intAnzahlGruen As Integer
Dim intKlasse As Integer
Dim intName As Integer
Dim intBME As Integer
Dim intZeileQuelle As Integer
Dim intZeileZiel As Integer
Dim strMessage As String
…
Hier kommt die Überprüfung ob ein Abgleich notwendig ist und der Blattschutz wird aufgehoben.
…
'* Sortieren
ThisWorkbook.Worksheets("Bestand_Bestellung").Cells(6, 1).Activate
Selection.Sort Key1:=Range("A7"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'* Überflüssige Zeilen löschen und Farbe zurücksetzen
intEnde = ThisWorkbook.Worksheets("Bestand_Bestellung").Cells(7, 1).End(xlDown).Row - 1

Und hier fangen die Schwierigkeiten an.
For Each c In Range(Cells(7, 1), Cells(intEnde, 1))
If c = c.Offset(1, 0) Then
c.EntireRow.Interior.ColorIndex = xlNone
'* Name des Vordruckes abgleichen
If (c.Offset(0, 1) <> c.Offset(1, 1)) Then
c.Offset(0, 1) = c.Offset(1, 1)
intName = intName + 1
End If
'* Sparte abgleichen
If (c.Offset(0, 2) <> c.Offset(1, 2)) Then
c.Offset(0, 2) = c.Offset(1, 2)
c.Offset(0, 3) = strBestellzyklus(c.Offset(0, 2))
intKlasse = intKlasse + 1
End If
'* Stück pro Bestellmengeneinheit abgleichen
If (c.Offset(0, 12) <> c.Offset(1, 12)) Then
c.Offset(0, 12) = c.Offset(1, 12)
intBME = intBME + 1
End If
c.Offset(1, 0).EntireRow.Delete
End If
Next c
Ab hier ist wohl wieder alle I.O.
'* Zählen der weggefallenen und neuen Vordrucke
intAnzahlRot = 0
intAnzahlGruen = 0
intEnde = ThisWorkbook.Worksheets("Bestand_Bestellung").Cells(7, 1).End(xlDown).Row
For Each c In Range(Cells(7, 1), Cells(intEnde, 1))
If c.Interior.ColorIndex = 3 Then
'* rote sperren
intAnzahlRot = intAnzahlRot + 1
c.Offset(0, 14) = 0
c.Offset(0, 15) = ""
c.Offset(0, 14).Locked = True
c.Offset(0, 15).Locked = True
End If
If (c.Interior.ColorIndex = 4) Then intAnzahlGruen = intAnzahlGruen + 1
Next c
Application.ScreenUpdating = True
Vorab schon einmal vielen Dank für die Mühe die ihr euch macht ;-)
Gruß - Dirk