Programmering af modul til excel

Du kan da prøve om denne her løser dit problem
http://www.win-consult.com/SmartOffice/produkter/Compare2Column.asp

Jeg forstår ikke at du ikke kan få min makro til at virke.
I vba-editoren under TOOLS - REFERENCES finder du Microsoft Scripting Runtime og sætter et flueben ud for det.
Når Du kører makroen bliver du først spurgt om "Overskrifter i område 1". Her markerer du overskrifterne på ark1
næste spm. er "Marker 1.celle i sammenligningskolonnen" . Her markerer du celle C1.
Så kommer overskrifter i Ark2 og sammenligningskolonnen
Til sidst blver du spurgt om hvor du vil have resultatet.
Makroen burde være færdig på under 10 sek.


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
      .ScreenUpdating = False
  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
 
  Set ReturnArray = Nothing
  Application.ScreenUpdating = True
  MsgBox "Færdig  tid : " & Timer - StartTid
 
End Sub

Sub DoCompare2Lists(ws1 As Range, ws2 As Range, SearchCol1 As Long, SearchCol2 As Long, aForskel As Variant)
  Dim dctCol As Scripting.Dictionary
  Dim Fundet As Boolean
  Dim Cols2 As Long, Last1 As Long, Last2 As Long, i As Long, z As Long, x As Long
  Dim st As String
  Set dctCol = 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
        st = CStr(.Cells(i, SearchCol1))
        dctCol.Add Item:=st, Key:=st
      Next
  End With
 
  On Error GoTo 0
 
  With ws2
      For i = 1 To Last2
        Fundet = dctCol.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 dctCol = Nothing

End Sub

bak nu har jeg rettet i din, den skulle nu køre.
den gemmer alle i Ark3 A kolonne

Option Base 1

Sub Init_Compare()

  '''Dim af variable
    Dim TB1 As Range, TB2 As Range, TB3 As Range, TB4 As Range
    Dim Temp As Range, Last3 As String
    Dim IndexCol1 As Long, IndexCol2 As Long
    Dim StartTid As Double
    Dim ReturnArray As Variant
   
    Set TB1 = Sheets("Ark1").Range("A1:F1") '1. inputområde (kolonner hvor værdierne tages med over her A til F)
    Set TB2 = Sheets("Ark2").Range("A1:F1") '2. inputområde (kolonner hvor værdierne tages med over her A til F)
   
    Set TB3 = Sheets("Ark3").Range("A1")    '1. outputområde
    IndexCol1 = 1  'anden kolonne i TB1 (B)
    IndexCol2 = 1  '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
   
    Last3 = TB3.Cells(65536, 1).End(xlUp).Offset(1, 0).Address
    Set TB4 = Sheets("Ark3").Range(Last3)    '2. outputområde
   
    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

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

Hej
Den løsning som Bak giver mig virker egentlig fint men den kopierer ikke hele den linie som ikke findes i begge ark over på ark3.
Sidste løsning som kabbak kommer med gør dette men den kopierer til gengæld alle linier fra begge ark over i ark3.
Jeg kan ikke se mig ud af koden hvad der sker da jeg endnu ikke har den store kendskab til VBA

ger bestemmer du hvilke kolonner den sammenligner

IndexCol1 = 1  'anden kolonne i TB1 (B)
IndexCol2 = 1  'anden kolonne i TB2 (B)

nu havde jeg ikke set at det var C kolonnen,
Så skal den se sådan ud

IndexCol1 = 3  'anden kolonne i TB1 (B)
IndexCol2 = 3 'anden kolonne i TB2 (B)

ger = her

IndexCol1 = 3  'tredie kolonne i TB1 (C)
IndexCol2 = 3 'tredie kolonne i TB2 (C)

Det fungerer fint men der er et lille problem, den tager ikke hele linien med over i ark 3. Den kopierer kun de første 6 kolonner. i Ark2 findes der data helt ud i X kolonnen som jeg gerne vil have kopieret med over.

Set TB1 = Sheets("Ark1").Range("A1:X1") '1. inputområde (kolonner hvor værdierne tages med over her A til X)
    Set TB2 = Sheets("Ark2").Range("A1:X1") '2. inputområde (kolonner hvor værdierne tages med over her A til X)

så har jeg en løsning som fungerer. Jeg har endnu ikke analyseret løsningen fra i går i forhold til denne her, men er lidt nysgerrig efter at vide hvorfor den fra i går ikke fungerer. Var det pga. store datamængder. Den fungerede fint hvis man kun brugte meget små datamængder.

Det er 2 forskellige måder at behandle dataerne på, denne læser alt i hukommelsen og behandler det der, den du fik i går arbejder mere i excel.

jeg er har heller ikke den store erfaring i at skrive, den som du fik nu.
Det er en rettet( modifiseret) udgave, af en som bak har lavet.

Han er nok den bedste til at forklare om hvad forskellen er.

jeg synes at du skal give bak point, der er jo hans makro. ;-p

ok det gør jeg, men jeg har stadig ikke rigtig fundet ud af hvordan jeg kan tildele point selv. Jeg får altid knapperne frem under kommentarerne ved udfør knappen.

det kan du ikke, bak skal svare først, vi har kun skrevet kommentarer.

Ok så må han lige sende et svar. Jeg takker endnu en gang for hjælpen.

Grunden til at den ikke kopierer hele linien over som standard, er at de overskrifter man markerer, er de kolonner man kopiere over. Altså man kan selv bestemme hvor meget man ønsker medtaget. Dette giver mindre datamængde at arbejde med.
Makroen benytter sig af at læse alle data ind først inden sammenligningen foregår

Jeg synes nu at vi skal dele, Kabbak. Når jeg nu ikke kan være her hele tiden :-)

ok jeg smider et svar, så må kef jo fordele points.

Den virrkelige grund til hastighed og stabilitet her er at jeg benytter Scripting.Dictionary.
Det er et specielt object, hvor man samtidig med at man læser indexkolonnen ind i det, laver et rigtigt index.
Derfor kan man nøjes med disse to linier og et meget hurtigt check på om data findes  den ene kolonne.

Fundet = xCol.Exists(CStr(.Cells(i, SearchCol2)))
    If Not Fundet = True Then

Normalt ville man skulle løbe dine 10000 varenumre igennem 1700 gange for at få samme check.