Avatar billede olehen Nybegynder
06. maj 2010 - 22:27 Der er 7 kommentarer og
1 løsning

Sammenlign 2 EXCEL ark på flere betingelser

Ark1 indeholder 44.0000 rækker
Ark2 indeholder 4.600 rækker

Jeg har en to ark hvor jeg gerne vil have den kigger på første række i ark2 og hvis kolonne "M" - EUR og "Q" - Dokument no findes i ark1 kolonne "I" - EUR og "B" - Dokument no så skal den klippe hele rækken ud af ark1 og indesætte den i ark3.

Løkken forsætter så til næste række i ark2. Findes denne række ikke i ark2 skal den klippen rækken ud af ark2 og indesætte den i ark4.

På den måde burde jeg kunne finde alle dataene i ark2 som stemmer med ark3.

De rækker der ikke findes er så tilbage i ark1 og ark4. 

Har forsøgt med denne kode men det kræver at dataene er sorteret.
Sub Find_Ikke_Ens_I_Ark()
Dim F, C, T, U, A As Integer, Q As Boolean
Application.ScreenUpdating = False
A = 2

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

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

For T = 2 To F
Q = True
For C = 2 To U
Worksheets("Project Data").Activate
If Worksheets("Project Data").Cells(T, 17) = Worksheets("FI Data").Cells(C, 2) _
And Worksheets("Project Data").Cells(T, 13) = Worksheets("FI Data").Cells(C, 9) Then
Q = False
GoTo Skift
End If


Next C

Skift:
If Q = True Then
    Sheets("FI Data").Select
    Rows(T & ":" & T).Select
    Selection.Cut
    Sheets("Sheet3").Select
    Rows(A & ":" & A).Select
    ActiveSheet.Paste
    A = A + 1
    Q = False
    Application.CutCopyMode = False
  End If
  Sheets("FI DATA").Select
  If Range("A" & T) <> "" Then
  Else
  Range("A" & T).EntireRow.Delete xlUp
  End If
Next T
Sheets("Sheet3").Select
Application.ScreenUpdating = True
Application.CutCopyMode = False
Range("A1").Select
End Sub
Avatar billede olehen Nybegynder
09. maj 2010 - 14:17 #1
Ingen der har et løsningsforslag?
Avatar billede olehen Nybegynder
09. maj 2010 - 15:53 #2
Nedenstående kode finder kun de der er forskellige men hvis der er ekstra datarækker bliver disse ikke sorteret fra. Hvorfor?

Option Explicit

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

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

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

For C = 2 To U
Q = True
For T = 2 To F
Worksheets("Project Data").Activate
If Worksheets("Project Data").Cells(T, 17) = Worksheets("FI Data").Cells(C, 2) _
And Worksheets("Project Data").Cells(T, 13) = Worksheets("FI Data").Cells(C, 9) Then
Q = False
GoTo Skift
End If


Next T

Skift:
If Q = True Then
    Sheets("FI Data").Select
    Rows(T & ":" & T).Select
    Selection.Cut
    Sheets("FI diff from CO").Select
    Rows(A & ":" & A).Select
    ActiveSheet.Paste
    A = A + 1
    Q = False
    Application.CutCopyMode = False
  End If
'  Sheets("FI DATA").Select
'  If Range("A" & T) <> "" Then
'  Else
'  Range("A" & T).EntireRow.Delete xlUp
'  End If
Next C
Sheets("FI diff from CO").Select
Application.ScreenUpdating = True
Application.CutCopyMode = False
Range("A1").Select
End Sub



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

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

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

For T = 2 To F
Q = True
For C = 2 To U
Worksheets("Project Data").Activate
If Worksheets("Project Data").Cells(T, 17) = Worksheets("FI Data").Cells(C, 2) _
And Worksheets("Project Data").Cells(T, 13) = Worksheets("FI Data").Cells(C, 9) Then
Q = False
GoTo Skift
End If


Next C

Skift:
If Q = True Then
    Sheets("Project Data").Select
    Rows(T & ":" & T).Select
    Selection.Cut
    Sheets("CO diff from FI").Select
    Rows(A & ":" & A).Select
    ActiveSheet.Paste
    A = A + 1
    Q = False
    Application.CutCopyMode = False
  End If
'  Sheets("Project Data").Select
'  If Range("A" & T) <> "" Then
'  Else
'  Range("A" & T).EntireRow.Delete xlUp
'  End If
Next T
Sheets("CO diff from FI").Select
Application.ScreenUpdating = True
Application.CutCopyMode = False
Range("A1").Select
End Sub
Avatar billede kabbak Professor
10. maj 2010 - 23:18 #3
prøv at teste, jeg er ikke helt klar over om det er det du ønsker.
Koden er tunet, så jeg kan ikke lave den hurtigere.

Option Explicit
Option Base 1    ' alle variabler starter ved 1

Sub Find_Ikke_Ens_I_Ark()
    Dim F, C, T, U, A As Integer, RW As Long
    Dim ProjectData As Variant, FIData As Variant
    Dim FIFind As String, PRFind As String
    Dim PR() As Variant, FI As Variant, CO As Integer
    Application.ScreenUpdating = False


    FIData = Worksheets("FI Data").Range("A1").CurrentRegion
    ProjectData = Worksheets("Project Data").Range("A1").CurrentRegion
    ReDim PR(UBound(ProjectData, 1))
    ReDim FI(UBound(FIData, 1))
    'Worksheets("Project Data").Cells(T, 17) = Worksheets("FI Data").Cells(C, 2) _
    'Worksheets("Project Data").Cells(T, 13) = Worksheets("FI Data").Cells(C, 9) Then
    For C = 2 To UBound(FIData, 1)
        FIFind = FIData(C, 2) & FIData(C, 9)    ' kopler de to celler fra "FI Data" sammen i en strengvariabel

        For T = 2 To UBound(ProjectData, 1)
            PRFind = ProjectData(T, 17) & ProjectData(T, 13)    ' kopler de to celler fra "Project Data" sammen i en strengvariabel

            If PRFind = FIFind Then
                FI(C) = "ENS"
                PR(T) = "ENS"
                Exit For
            Else
                If PR(T) <> "ENS" Then PR(T) = Empty
            End If
        Next T
    Next C


    ' overfører de rækker fra "FI Data" der ikke var en makker til i "Project Data" til "FI diff from CO"
    A = 2
    For C = 2 To UBound(FIData, 1)
        If IsEmpty(FI(C)) Then
            For T = 1 To UBound(FIData, 2)
                Sheets("FI diff from CO").Cells(A, T) = FIData(C, T)
                FIData(C, T) = Empty
            Next
            A = A + 1
        End If
    Next
    ' overfører de rækker fra "Project Data" der ikke var en makker til i "FI Data" til "CO diff from FI"

    A = 2
    For T = 2 To UBound(ProjectData, 1)
        If IsEmpty(PR(T)) Then
            For C = 1 To UBound(ProjectData, 2)
                Sheets("CO diff from FI").Cells(A, C) = ProjectData(T, C)
                ProjectData(T, C) = Empty
            Next
            A = A + 1
        End If
    Next
    'Skriver tilbage til arket"Project data", uden dem der ikke var ens
    RW = Worksheets("Project Data").Range("A1").CurrentRegion.Rows.Count
    CO = Worksheets("Project Data").Range("A1").CurrentRegion.Columns.Count
    Worksheets("Project Data").Range("A1").CurrentRegion = ProjectData
    'Sortering
    Worksheets("Project Data").Select
    Range(Cells(1, 1), Cells(RW, CO)).Select
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
                  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                  DataOption1:=xlSortNormal

    'Skriver tilbage til arket"FI Data", uden dem der ikke var ens
    RW = Worksheets("FI Data").Range("A1").CurrentRegion.Rows.Count
    CO = Worksheets("FI Data").Range("A1").CurrentRegion.Columns.Count
    Worksheets("FI Data").Range("A1").CurrentRegion = FIData
    'Sortering
    Worksheets("FI Data").Select
    Range(Cells(1, 1), Cells(RW, CO)).Select
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
                  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                  DataOption1:=xlSortNormal

    Sheets("FI diff from CO").Select
    Application.ScreenUpdating = True
    Range("A1").Select
End Sub
Avatar billede olehen Nybegynder
10. maj 2010 - 23:30 #4
Tager den højde for overskrifter i første række?
Avatar billede olehen Nybegynder
10. maj 2010 - 23:51 #5
Jeg kan sende dig filen. Lige nu kopiere den alle dataene fra de to ark til to nye ark. Det ser ikke ud til den sammenligner rækkerne pga. af de to betingelser.

Det den skal er på baggrund af de to betingelser:

Sammenligne arkene ("FI DATA" og "Project DATA")

Find ens værdier i FI Data og Project Data og kopiere dem over i hver sit ark "FI diff" fra "FI DATA" ens med "CO diff" fra "PROJECT DATA".
Avatar billede olehen Nybegynder
10. maj 2010 - 23:59 #6
Aaarh, det ser dælme godt ud.. Har fået den til at virke (Skulle lige korrigere en kolonne), så nu skal den køres gennem på det store ark.. 

Super tak for den hurtige hjælp.
Avatar billede kabbak Professor
17. maj 2010 - 08:07 #7
Hvordan går det, kører koden som den skal ??
Avatar billede olehen Nybegynder
17. maj 2010 - 14:36 #8
Det gik udemærket, den løste opgaven 99%. Der var en mindre mismatch men uden betydning i den total opgørelse.

Var dog nød til at splitte datasættet op og køre koden 3 gange, da der opstod en overload omkring linie 32.000.
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester