Sammenlignings makro (meget langsom)

Kan du sende et eksempel ark ?
tc@elvis.dk

blackadder >> jeg skal lige slette cpr.nr. osv. sender det omlidt

sendt

Modtaget.

Hmm, den crashede lige min Excel...

Det er ellers lidt af en beregning.
Hvis jeg forstår det korrekt, så skal den
sammenligne ca. 20.000 rækker med 20.000 andre rækker.

Ialt: 20.000 x 20.000 = 400.000.000 sammenligninger.

Så lidt tålmodighed er du nok nødt til at have  :-)

Ja ... det kan jeg godt se ... men det er ikke tilfredstillende at den crasher, Hvis man nu kunne lave den bare lidt hurtigere vil den nok også blive mere stabil

Hej chewie

Var det ikke en idé, at placere dine data i Access og lave en SQL forespørgsel, som sammenlignede dine kolonner. Jeg mener, at det er en Outerjoin der skal anvendes. Du kan stadig gøre det fra Excel, ved at koble dig på databasen i din VBA kode.

Men jeg har et også et eksempel, som kan udføre sammenligningen på 20000 rækker. Eksemplet tester kun på den ene række og ikke omvendt, men det kan jo laves :-)
Det tager ca. 1 min på min maskine at sammenligne. Eksemplet ser således ud:

Function Sammenlign(ByVal refmyrange As Range, ByVal Myrange As Range) As Boolean
    On Error GoTo errhandler
   
    If Not IsError(Application.WorksheetFunction.Match(refmyrange, Myrange, 0)) Then Sammenlign = True
    Exit Function
errhandler:
    Sammenlign = False
End Function

Sub Test()
Set Myrange = Worksheets("Ark1").Range(Cells(1, 2), Cells(20000, 2))
a = 1
For i = 1 To 20000
Set refmyrange = Worksheets("Ark1").Cells(i, 1)

If Not Sammenlign(refmyrange, Myrange) Then
    Worksheets("Ark1").Cells(a, 3).Value = Worksheets("Ark1").Cells(i, 1)
    a = a + 1
End If
Next
End Sub

chewie
Nu kan jeg se du allerede har lavet een del, og ved ikke om du har set nedenstående før. Jeg ved heller ikke om de er hurtigere (som blackadder siger, så er det grumme mange sammenligninger) men det er da værd at prøve.

http://support.microsoft.com/default.aspx?scid=kb;en-us;139882
http://j-walk.com/ss/excel/usertips/tip073.htm

Den sidste laver ikke en list, men markerer blot dom der afviger, så hvis du vil have en liste, så behøver du ikke se på den.

fobian >> jeg kan ikke rigtig få det til at funke

fobian >> den skal ligge i et modul ik ?

Ja - koden skal placeres i et modul.
I eksemplet er det Ark1 der refereres til.
Den ene kolonne med data er placeret i området a1:a20000
Den anden kolonne er placeret i området b1:b20000.

Hvis du ikke kan få det til at virke, kan jeg sende regnearket til dig via mail :-)

Prøv denne her:
---------------
Sub FindUnique()

Dim ny, fast, resultat As Worksheet
Dim nyRowCount, fastRowCount, resultatRowCount, i, j, k As Integer
Dim nyCol, fastCol As Variant
Dim duplicate As Boolean

Set ny = Worksheets("NyListe")
Set fast = Worksheets("FastListe")
Set resultat = Worksheets("ResultatListe")

nyRowCount = ny.UsedRange.Rows.Count
fastRowCount = fast.UsedRange.Rows.Count
resultatRowCount = 1

resultat.Cells.Delete

ny.Activate
nyCol = ny.Range(Cells(2, 2), Cells(nyRowCount, 2))
fast.Activate
fastCol = fast.Range(Cells(2, 2), Cells(fastRowCount, 2))

duplicate = False

Worksheets("ResultatListe").Activate
k = 1

breakpoint:
For i = k To UBound(nyCol, 1)
duplicate = False
Application.StatusBar = "Sammenligner række: " & i
    For j = 1 To UBound(fastCol, 1)
        If nyCol(i, 1) = fastCol(j, 1) Then
            duplicate = True
            k = i + 1
            GoTo breakpoint
        End If
    Next j
    If duplicate = False Then
        Worksheets("ResultatListe").Cells(resultatRowCount, 1) = nyCol(i, 1)
        resultatRowCount = resultatRowCount + 1
    End If
Next i

Application.StatusBar = False

End Sub

-----------------------

Den bruger "bak-metoden", med et variant-array der indlæses i hukommelsen.
Den tager ca. 5 min. på min egen maskine.

Denne makro tager 14 sek. om 2*20000 celler med 4000 rækker der skal overføres til resultatlisten (på en gammel P350 mhz og 128Ram)
Inden makroen køres skal du under Tools / References sætte flueben i "MicroSoft Scripting Runtime"
Den er sat til at chekke kolonne B og overføre cellerne fra kolonne A-F.


Option Explicit
Option Base 1
'''Skriver alle de værdi, der findes i TB2 og IKKE i TB1, til TB3
Sub Compare2()
  '''Dim af variable
  Const SearchCol As Long = 1
  Const MaxCols As Long = 6
 
  Dim TB1 As Worksheet, TB2 As Worksheet, TB3 As Worksheet
  Dim xcol As Scripting.Dictionary
  Dim aForskel
  Dim starttid As Double
  Dim fundet As Boolean, Last1 As Long, Last2 As Long
  Dim i As Long, z As Long, x As Long
 
  '''Initialisering af variabler
  starttid = Timer
  Set xcol = New Scripting.Dictionary
  Set TB1 = ActiveWorkbook.Worksheets("NyListe")
  Set TB2 = ActiveWorkbook.Worksheets("FastListe")
  Set TB3 = ActiveWorkbook.Worksheets("ResultatListe")
 
  Last2 = TB2.Range("A65536").End(xlUp).Row
  Last1 = TB1.Range("A65536").End(xlUp).Row
  ReDim aForskel(Last2, MaxCols)
  z = 0
 
  '''Hent alle værdi fra TB1 ind i Collection xcol
  On Error Resume Next
  For i = 1 To Last1
      xcol.Add Item:=CStr(TB1.Cells(i, SearchCol)), Key:=CStr(TB1.Cells(i, SearchCol))
  Next
 
  '''Check alle celler i TB2 (kol A) om disse findes i xcol
  '''Hvis de ikke gør så placer dem i varianten aForskel
  On Error Resume Next
 
  For i = 1 To Last2
    If xcol.Exists(CStr(TB2.Cells(i, SearchCol))) Then fundet = True Else fundet = False
      If fundet = False Then
        z = z + 1
        For x = 1 To MaxCols
            aForskel(z, x) = TB2.Cells(i, x)
        Next
      End If
      fundet = True
 
  Next
  Set xcol = Nothing
  Application.StatusBar = "Beregning færdig, fylder nu celler"
  '''Overfør aForskel til TB3
  TB3.Range(Cells(1, 1), Cells(UBound(aForskel, 1), MaxCols)) = aForskel
  MsgBox "færdig  tid : " & Timer - starttid
  Set xcol = Nothing
  Set aForskel = Nothing
  Application.StatusBar = False
End Sub

Rettelse, den er sat til at chekke A-kolonnerne, men du kan sætte den til B-kolonnerne ved at ændre SearchCol til 2

bak >> Den kører fint på min (1.64 sek) , men den skriver ikke noget i resultat arket.

Måske har jeg rodet det lidt rundt :-)
Hvis en linie fra FastListe ikke findes i NyListe skriver den linien fra fastliste. Det er nu ikke et stort problem at ændre, jeg skal bare lige vide hvad der ønskes på resultatarket. Jeg blev nok lidt forvirret.
De skriver godt nok fint her.
Men du må da indrømme at den er hurtig....... :-)

PS. er der noget i din kolonne A ?

Pokkers, jeg havde jo lavet en lille fehler :-(

disse to linier skal ændres
  Last2 = TB2.Range("A65536").End(xlUp).Row
  Last1 = TB1.Range("A65536").End(xlUp).Row

til

Last2 = TB2.Cells(65536, SearchCol).End(xlUp).Row
Last1 = TB1.Cells(65536, SearchCol).End(xlUp).Row

Blackadder-> jeg sad lige og kiggede på din kode.
Du dimmer dine variable som i gamle dage i Basic.

Dim ny, fast, resultat As Worksheet
Der ville alle disse blive til Workssheet

Den går ikke i VBA
Så bliver ny til variant, fast til variant og resultat til Worksheet
Altså hver enkelt variabel skal have koblet type på

Dim ny as Worksheet, Fast as WorkSheet, Resultat as Worksheet

Beklager at rette på din kodning, men man skal jo lære en gang noget imellem :-)

bak >> Tak for rettelsen. Det undrede mig også lidt at jeg ikke kunne bruge range property på ny og fast... hvilket forklarer disse linier

ny.Activate
nyCol = ny.Range(Cells(2, 2), Cells(nyRowCount, 2))
fast.Activate
fastCol = fast.Range(Cells(2, 2), Cells(fastRowCount, 2))

Det med variablerne er en gammel vane fra C++.
Jeg var ikke klar over at den ikke gik i VBA.

Min version sammenligner kolonne B i ark 'ny' og 'fast'. Uagtet kolonne A.

Bliv endelig ved med at rette, man lærer trods alt bedst af sine fejl  :-)

Hej

Undskyld jeg har været fraverne ......

bak >> jeg kan ikke rigtig få det til at funke ... det ser ud til at makroen køre fint .... men der kommer ikke noget på "ResultatLise"

Hvad tror du jeg gør forkert ??

chewie

ok, chewie. Den burde virke med den lille rettelse, men jeg har nu prøvet at lave en mere generel makro til dette formål. Jeg er ikke helt færdig men du kan da få en "beta"-version, så kan vi jo se om der nogensinde kommer en endelig version :-)
Denne makro Chekker begge veje og laver 2 resultater ved siden af hinanden.
Ca. 35 sek. for 20000 * 2 rækker.
Sub Init_Compare sørger bare for opsætning til Compare2Lists, som er motoren.
Du skal bare udpege overskrifter for hvert område, når du bliver spurgt og derefter første celle i den kolonne der skal bruges til sammenligning.
De kolonner der bliver markeret under udvælgelse af overskrifter er også dem der "flyttes" med om i det udpegede resultatark.
Test og vend tilbage.


Option Explicit
Option Base 1
Sub Init_Compare()
  '''Dim af variable
  Dim TB1 As Range, TB2 As Range, TB3 As Range
  Dim Temp As Range
  Dim IndexCol1 As Long, IndexCol2 As Long
  Dim StartTid As Double
  Dim ReturnArray As Variant
 
  With Application
      Set TB1 = .InputBox("Marker overskrift af område 1", Type:=8)
      TB1.Parent.Activate
      Set Temp = .InputBox("Marker 1.celle i sammenligningskolonnen", Type:=8)
      IndexCol1 = Temp.Column - TB1.Column + 1
      Set TB2 = .InputBox("Marker overskrift af område 2", Type:=8)
      TB2.Parent.Activate
      Set Temp = .InputBox("Marker 1.celle i sammenligningskolonnen", Type:=8)
      IndexCol2 = Temp.Column - TB2.Column + 1
      Set TB3 = .InputBox("Marker 1. celle af resultatområde", Type:=8)
      TB3.Parent.Activate
  End With
 
  StartTid = Timer
  DoCompare2Lists TB1, TB2, IndexCol1, IndexCol2, ReturnArray
  TB3.Range(TB3.Cells(1, 1), TB3.Cells(UBound(ReturnArray, 1), UBound(ReturnArray, 2))) = ReturnArray
 
  DoCompare2Lists TB2, TB1, IndexCol2, IndexCol1, ReturnArray
  TB3.Range(TB3.Cells(1, TB2.Columns.Count + 1), TB3.Cells(UBound(ReturnArray, 1), UBound(ReturnArray, 2) + TB2.Columns.Count)) = ReturnArray
 
  MsgBox "Færdig  tid : " & Timer - StartTid
  Set ReturnArray = Nothing
End Sub

Sub DoCompare2Lists(WS1 As Range, WS2 As Range, SearchCol1 As Long, SearchCol2 As Long, aForskel As Variant)
  Dim xCol As Scripting.Dictionary
  Dim Fundet As Boolean, Last1 As Long, Last2 As Long
  Dim Cols2 As Long
  Dim i As Long, z As Long, x As Long
 
  Set xCol = New Scripting.Dictionary
  Cols2 = WS2.Columns.Count
  Last1 = WS1.Cells(65536, SearchCol1).End(xlUp).Row
  Last2 = WS2.Cells(65536, SearchCol2).End(xlUp).Row
  ReDim aForskel(Last2, Cols2)
  z = 0
 
  On Error Resume Next
  With WS1
      For i = 1 To Last1
        xCol.Add Item:=CStr(.Cells(i, SearchCol1)), Key:=CStr(.Cells(i, SearchCol1))
      Next
  End With
  With WS2
      For i = 1 To Last2
        Fundet = xCol.Exists(CStr(.Cells(i, SearchCol2)))
        If Not Fundet = True Then
            z = z + 1
            For x = 1 To Cols2
              aForskel(z, x) = .Cells(i, x)
            Next
        End If
        Fundet = True
      Next
  End With
  Set xCol = Nothing
End Sub

Jeg bøjer mig i støvet... :-)
Den virker og er tilmed møg-hurtig.

Den kan vistnok også klares med denne array formel:

Indsæt i ResultatListe og træk nedad
=IF(COUNTIF(NyListe!B2:B20723;FastListe!A2)=0;B1;"")

Hold kæft hvor det virker .... det er helt vildt !!

bak du er gud :o) ..... mange tak

400 millioner udregninger på 19.8 sek.

Skal lige teste den array formel lidt mere, umiddelbart ser det ud til at kunne lade sig gøre...

Dropper lige array formlen...
Den kom til at indeholde alle de blanke rækker
og er nok alligevel ikke hurtigere end bak's  :-)

Tak for det, gutter. Men helst ingen knæfald, jeg er ikke engang guru endnu :-)
Dette var et lille eksperiment for mig med scripting.Dictionary.
En dejlig lille avanceret ting, der ikke står så meget om i hjælpen.

Hmm ... jeg havde ingen problemmer med afkrysning af MS scripting Runtime på min PC hjemme .... men her på arbejdet dumper excel :o(

http://www.eksperten.dk/spm/348545

hmm hmm .. hvis jeg åbner det ark jeg har lavet hjemme ... er Runtime afkrysset også virker det :o) .... men det er da stadig underligt at jeg ikke kan her på arbejdet :(

Måske ikke. Nogle firmaer vælger ikke at installere scripting runtime, som en ekstra virus-sikring. Check lige om I har valgt dette.
Eller må vi jo lave det om, det er sikkert ikke umuligt, men kan blive lidt langsommere :-)

Så har jeg sat vores HELP disk på sagen ..... elsker når jeg kan stille dem spg. de ikke kan svare på, på stående fod :o)

Hmm ... tilsyneladende en fejl på min PC ... HELP køre en reloader ...even

bak >> der er en lille fejl i koden eller en lille ting der ikke er taget højde for ...... hvad hvis der ikke er nogle overskrifter på listen ??

Jeg prøvet bare at vælge de øverste celler til alle imput spg´ne ... men så debugger den på

Last1 = WS1.Cells(65536, SearchCol1).End(xlUp).Row

chewie

Tilsyneladende fordi .. der er valgt 2 x B1

eks.
--------------------------------
      Set TB1 = .InputBox("Marker overskrift af område 1", Type:=8)
      TB1.Parent.Activate

her vælger jeg: A1, B1, C1, D1
-------------------------------------

      Set Temp = .InputBox("Marker 1.celle i sammenligningskolonnen", Type:=8)
      IndexCol1 = Temp.Column - TB1.Column + 1

her vælger jeg: B1
--------------------------------

Nej, det ser rigtig nok ud.
prøv lige at fjerne alle de xx.Parent.activate.

Jeg har så brugt lidt tid på at få det til at køre uden scripting runtime og jeg tror jeg har opnået samme hastighed :-)

skal jeg fjerne

      TB1.Parent.Activate
      TB2.Parent.Activate
      TB3.Parent.Activate

helt ??

yes

Du kan (for at teste) prøve at bruge dette modul.
Sub Init_Compare()

  '''Dim af variable
    Dim TB1 As Range, TB2 As Range, TB3 As Range, TB4 As Range
    Dim Temp As Range
    Dim IndexCol1 As Long, IndexCol2 As Long
    Dim StartTid As Double
    Dim ReturnArray As Variant
   
    Set TB1 = Sheet1.Range("A1:F1") '1. inputområde
    Set TB2 = Sheet2.Range("A1:f1") '2. inputområde
   
    Set TB3 = Sheet3.Range("A1")    '1. outputområde
    Set TB4 = Sheet3.Range("G1")    '2. outputområde
    IndexCol1 = 2  'anden kolonne i TB1 (B)
    IndexCol2 = 2  'anden kolonne i TB2 (B)
   
    StartTid = Timer
   
    DoCompare2Lists TB1, TB2, IndexCol1, IndexCol2, ReturnArray
    Set TB3 = TB3.Resize(UBound(ReturnArray, 1), UBound(ReturnArray, 2))
    TB3 = ReturnArray
   
    DoCompare2Lists TB2, TB1, IndexCol2, IndexCol1, ReturnArray
    Set TB4 = TB4.Resize(UBound(ReturnArray, 1), UBound(ReturnArray, 2))
    TB4 = ReturnArray
   
    Set ReturnArray = Nothing
    Application.ScreenUpdating = True
    MsgBox "Færdig  tid : " & Timer - StartTid

End Sub

Jeg fik det til at funke nu :o) ved ikke hvad jeg har gjort forkert før .. even

prøver lige dit nye mester værk :o)

Hvis det virker behøver du ikke prøve det nye. Det sætter bare input og outputområdene fra start.

OK ... tak for hjælpen endnu engang

Hvis det nu er .... mine ark hedder jo FastListe og NyListe skal denne

    Set TB1 = Sheet1.Range("A1:F1") '1. inputområde

så ikke hedde

    Set TB1 = FastListe.Range("A1:F1") '1. inputområde

eksempelvis

Nix,
Set TB1 = Sheets("FastListe").Range("A1:F1") '1. inputområde

OK :o)

BTW jeg har testet på min arbejds-pc (P1500 og 400MB-ram) på 22000 *22000 rækker. = 3 sek. rent

Ja .. det er godt nok hurtigt !!

jeg kører den her på ca. 8 sek.

Hej bak

Du lavede denne super fede makro i 2003 og nu har jeg pludselig fået brug for den igen. dog med et lille tvist .. jeg skal nu bruge alle dem som er ens.

kan du hjælpe med at tviste den ?

--


Option Explicit
Option Base 1
Sub Init_Compare()
  '''Dim af variable
  Dim TB1 As Range, TB2 As Range, TB3 As Range
  Dim Temp As Range
  Dim IndexCol1 As Long, IndexCol2 As Long
  Dim StartTid As Double
  Dim ReturnArray As Variant
 
  With Application
      Set TB1 = .InputBox("Marker overskrift af område 1", Type:=8)
      TB1.Parent.Activate
      Set Temp = .InputBox("Marker 1.celle i sammenligningskolonnen", Type:=8)
      IndexCol1 = Temp.Column - TB1.Column + 1
      Set TB2 = .InputBox("Marker overskrift af område 2", Type:=8)
      TB2.Parent.Activate
      Set Temp = .InputBox("Marker 1.celle i sammenligningskolonnen", Type:=8)
      IndexCol2 = Temp.Column - TB2.Column + 1
      Set TB3 = .InputBox("Marker 1. celle af resultatområde", Type:=8)
      TB3.Parent.Activate
  End With
 
  StartTid = Timer
  DoCompare2Lists TB1, TB2, IndexCol1, IndexCol2, ReturnArray
  TB3.Range(TB3.Cells(1, 1), TB3.Cells(UBound(ReturnArray, 1), UBound(ReturnArray, 2))) = ReturnArray
 
  DoCompare2Lists TB2, TB1, IndexCol2, IndexCol1, ReturnArray
  TB3.Range(TB3.Cells(1, TB2.Columns.Count + 1), TB3.Cells(UBound(ReturnArray, 1), UBound(ReturnArray, 2) + TB2.Columns.Count)) = ReturnArray
 
  MsgBox "Færdig  tid : " & Timer - StartTid
  Set ReturnArray = Nothing
End Sub

Sub DoCompare2Lists(WS1 As Range, WS2 As Range, SearchCol1 As Long, SearchCol2 As Long, aForskel As Variant)
  Dim xCol As Scripting.Dictionary
  Dim Fundet As Boolean, Last1 As Long, Last2 As Long
  Dim Cols2 As Long
  Dim i As Long, z As Long, x As Long
 
  Set xCol = New Scripting.Dictionary
  Cols2 = WS2.Columns.Count
  Last1 = WS1.Cells(65536, SearchCol1).End(xlUp).Row
  Last2 = WS2.Cells(65536, SearchCol2).End(xlUp).Row
  ReDim aForskel(Last2, Cols2)
  z = 0
 
  On Error Resume Next
  With WS1
      For i = 1 To Last1
        xCol.Add Item:=CStr(.Cells(i, SearchCol1)), Key:=CStr(.Cells(i, SearchCol1))
      Next
  End With
  With WS2
      For i = 1 To Last2
        Fundet = xCol.Exists(CStr(.Cells(i, SearchCol2)))
        If Not Fundet = True Then
            z = z + 1
            For x = 1 To Cols2
              aForskel(z, x) = .Cells(i, x)
            Next
        End If
        Fundet = True
      Next
  End With
  Set xCol = Nothing
End Sub