Makro beschleunigen?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Klaus,
Frage war: Hätte gerne per VBA, dass Spalte N in beiden Dateien abgeglichen
wird, und die Einträge, welche in "Alt" sind und nicht in "Neu"
in "Fehlende in Neu" geschrieben werden.
Gruß
Günter
hier meine Beispieldatei:
https://www.herber.de/bbs/user/71865.xls
Und hier der vollständige Code:
Option Explicit

Public Sub Abgleich()
Dim WkSh_A    As Worksheet
Dim WkSh_N    As Worksheet
Dim WkSh_F    As Worksheet
Dim lZeile_A  As Long
Dim lZeile_F  As Long
Dim rZelle    As Range
Application.ScreenUpdating = False
Set WkSh_A = ThisWorkbook.Worksheets("Alt")
Set WkSh_N = ThisWorkbook.Worksheets("Neu")
Set WkSh_F = ThisWorkbook.Worksheets("Fehlende in Neu")
lZeile_F = 12 ' die Start-Zeile in Fehlende in Neu minus 1
For lZeile_A = 13 To WkSh_A.Cells(Rows.Count, 14).End(xlUp).Row
With WkSh_N.Columns(14)
Set rZelle = .Find(What:=WkSh_A.Range("N" & lZeile_A).Value, LookAt:=xlWhole, _
LookIn:=xlValues)
If rZelle Is Nothing Then
lZeile_F = lZeile_F + 1
WkSh_A.Rows(lZeile_A).Copy Destination:=WkSh_F.Rows(lZeile_F)
End If
End With
Next lZeile_A
Application.ScreenUpdating = True
End Sub

Public Sub Abgleich() Dim WkSh_A As Worksheet Dim WkSh_N As Worksheet Dim WkSh_F As Worksheet Dim lZeile_A As Long Dim lZeile_F As Long Dim rZelle As Range Dim arr_F(), i As Integer Application.ScreenUpdating = False Set WkSh_A = ThisWorkbook.Worksheets("Alt") Set WkSh_N = ThisWorkbook.Worksheets("Neu") Set WkSh_F = ThisWorkbook.Worksheets("Fehlende in Neu") ReDim arr_F(1 To 14, 1 To Application.CountA(WkSh_A.Columns(14))) lZeile_F = 0 For lZeile_A = 13 To WkSh_A.Cells(Rows.Count, 14).End(xlUp).Row With WkSh_N.Columns(14) Set rZelle = .Find(What:=WkSh_A.Cells(lZeile_A, 14).Value, LookAt:=xlWhole, _ LookIn:=xlValues) If rZelle Is Nothing Then lZeile_F = lZeile_F + 1 For i = 1 To 14 arr_F(i, lZeile_F) = WkSh_A.Cells(lZeile_A, i) Next End If End With Next lZeile_A ReDim Preserve arr_F(1 To 14, 1 To lZeile_F) arr_F = WorksheetFunction.Transpose(arr_F) WkSh_F.Cells(13, 1).Resize(lZeile_F, 14) = arr_F Application.ScreenUpdating = True End Sub

Hallo Günther
Ich habs auch mal mit VBA versucht.
100000 in alt, 100000 in neu.
Der Code braucht auf meinem Erbsenzähler ca. 10 Sekunden.

Option Explicit

Public Sub test()
Dim L As Long
Dim Out As Variant
Dim arrAlt As Variant
Dim arrNeu As Variant
Dim Z As Long
Dim I As Integer
Dim myDic As Object
Dim t As Double
t = Timer
arrAlt = Sheets("alt").Range("A13").CurrentRegion
arrNeu = Sheets("neu").Range("A13").CurrentRegion
Redim Out(1 To UBound(arrAlt), 1 To UBound(arrAlt, 2))
Set myDic = CreateObject("Scripting.Dictionary")
For L = LBound(arrNeu) To UBound(arrNeu)
    myDic(arrNeu(L, 14)) = 0
Next
For L = LBound(arrAlt) To UBound(arrAlt)
    If Not myDic.exists(arrAlt(L, 14)) Then
        Z = Z + 1
        For I = 1 To UBound(arrAlt, 2)
            Out(Z, I) = arrAlt(L, I)
        Next
    End If
Next
Sheets("Fehlende in neu").Range("A1").Resize(Z, UBound(arrAlt, 2)) = Out
MsgBox Timer - t
End Sub

ransi

Sub test() Dim rngAlt As Range Dim rngNeu As Range Set rngAlt = Range(Sheets("Alt").Cells(13, 14), Sheets("alt").Cells(Rows.Count, 14).End(xlUp)) Set rngNeu = Range(Sheets("neu").Cells(13, 14), Sheets("Neu").Cells(Rows.Count, 14).End(xlUp)) rngNeu.EntireRow.Sort key1:=rngNeu.Cells(1, 1), order1:=xlAscending, Header:=xlNo With rngAlt.Offset(0, 1) .FormulaR1C1 = "=If(vlookup(RC[-1],Neu!" & rngNeu.Address(1, 1, xlR1C1) & ",1,1)=RC[-1],1, _ true)" .Copy .PasteSpecial xlPasteValues .EntireRow.Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlNo On Error Resume Next .SpecialCells(xlCellTypeConstants, 20).Offset(0, -1).Copy Sheets("Fehlende in Neu").Cells(1, _ 1) On Error GoTo 0 .Clear End With End Sub

Beliebteste Forumthreads (12 Monate)

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread