Programmering af modul til sammenligning af data i excel

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

den er her

det er baks svar 05/05-2003 13:23:16, du skal bruge

Jeg får en fejl. Den siger at Sub or Function not defined her.

DoCompare2Lists TB1, TB2, IndexCol1, IndexCol2, ReturnArray
    Set TB3 = TB3.Resize(UBound(ReturnArray, 1), UBound(ReturnArray, 2))
    TB3 = ReturnArray

ption 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


du skal have referance til Microsoft scripting runtime.

jeg skal til møde nu , kikker senere på dagen.

den kopierer ikke rækker endnu, skal tilpasses.

ption Explicit =Option Explicit

du får denne i stedet den virker


Sub Find_Ikke_Ens_I_Ark()
Dim F, C, T, U, A As Integer, Q As Boolean
Application.ScreenUpdating = False
A = 1

Worksheets("Ark1").Activate
F = ActiveCell.SpecialCells(xlLastCell).Row ' Finder ud af hvor mange rækker der er med data på ark1

Worksheets("Ark2").Activate
U = ActiveCell.SpecialCells(xlLastCell).Row ' Finder ud af hvor mange rækker der er med data på ark2

For T = 1 To F
Q = True
For C = 1 To U
Worksheets("Ark1").Activate
If Worksheets("Ark1").Cells(T, 2) = Worksheets("Ark2").Cells(C, 2) Then
Q = False
End If

Next C

If Q = True Then
    Sheets("Ark1").Select
    Rows(T & ":" & T).Select
    Selection.Copy
    Sheets("Ark3").Select
    Rows(A & ":" & A).Select
    ActiveSheet.Paste
    A = A + 1
    Q = False
    Application.CutCopyMode = False
  End If
Next T


Worksheets("Ark2").Activate
F = ActiveCell.SpecialCells(xlLastCell).Row ' Finder ud af hvor mange rækker der er med data på ark1

Worksheets("Ark1").Activate
U = ActiveCell.SpecialCells(xlLastCell).Row ' Finder ud af hvor mange rækker der er med data på ark2

For T = 1 To F
Q = True
For C = 1 To U
Worksheets("Ark2").Activate
If Worksheets("Ark2").Cells(T, 2) = Worksheets("Ark1").Cells(C, 2) Then
Q = False
End If

Next C

If Q = True Then
    Sheets("Ark2").Select
    Rows(T & ":" & T).Select
    Selection.Copy
    Sheets("Ark3").Select
    Rows(A & ":" & A).Select
    ActiveSheet.Paste
    A = A + 1
    Q = False
    Application.CutCopyMode = False
  End If
Next T

Sheets("Ark3").Select
Application.ScreenUpdating = True
Application.CutCopyMode = False
'Range("A1").Select
End Sub

Jeg tror du er sprumget dette punkt over.

Inden makroen køres første gang skal du under Tools / References sætte flueben i "MicroSoft Scripting Runtime"

Her er en husmandsløsning:-)
skriv i en af D-kolonnerne:
=HVIS(Ark1!C3=Ark2!C3;"Dublet";"")  så får du skrvet Dublet alle de steder, hvor der er sammenfald.
På ark3 skriver du i alle felter:
=HVIS(Ark2!$D3="Dublet";"";Ark1!$A3) 
Dette er hvad der skal stå i A3. Du kan selv passe til for øvrige felter i række 3 og så kopiere nedefter.

Kommentar: Det er kabbak's løsning som jeg anvender. Da han også var hutigst med svaret finder jeg det mest retfærdigt at tildele ham mine point. Håber på forståelse og takker for interessen for at løse mit problem.

du får lige et svar.

tak for points ;-))