Sammenligning af data

Sub FindEns()
Dim F As Integer, C As Integer, T As Integer, U As Integer
Worksheets("Ark3").Activate
U = 1 ' Finder ud af hvor mange rækker der er med data på ark3
Do Until Worksheets("Ark3").Cells(U, 2) = ""
U = U + 1
Loop
Worksheets("Ark1").Activate
F = 1 ' Finder ud af hvor mange rækker der er med data på ark2
Do Until Worksheets("Ark2").Cells(F, 2) = ""
F = F + 1
Loop
For T = 1 To F
Worksheets("Ark1").Activate
C = 1
Do Until Worksheets("Ark1").Cells(C, 2) = ""
If Worksheets("Ark2").Cells(T, 2) = Worksheets("Ark1").Cells(C, 2) Then
Worksheets("Ark1").Rows(C & ":" & C).Select
    Selection.Copy
    Sheets("Ark3").Select
    Rows(U & ":" & U).Select
    ActiveSheet.Paste
   
    Sheets("Ark2").Select
    Worksheets("Ark2").Rows(T & ":" & T).Select
    Selection.Copy
    Sheets("Ark3").Select
    Rows(U + 1 & ":" & U + 1).Select
    ActiveSheet.Paste
    U = U + 2
    Worksheets("Ark1").Activate
End If
  C = C + 1
  Loop
Next T

End Sub

Prøv denne makro, sæt den ind i et modul

Den Kopierer de ens linier under hinanden på ark3

Nu skriver du jo begge linier, men det er måske begge celler du mener.
Altså eks. Ark1 Celle(B2) og Ark2 Celle(B6), kopieres til Ark3 Celle(A1)og Celle(b1) .

Hejsa Det ser ud til at det virker som jeg gerne vil have det. Du havde forstået mit spørgsmål rigtigt, jeg ønskede at flytte hele linen for det enkelte linienummer og ikke kun indholdet af den enkelte celle, så det virker korrekt. Jeg vil teste det igennem i morgen, men accepterer svaret som værende ok i forhold til hvad jeg skal bruge nu. Jeg takker mange gange for et hurtigt og godt svar og vil helt sikkert vende tilbage med flere opgaver. TAK

Den flytter ikke linien den kopierer den kun

Hvis du vil slette linierne i ark1 og ark2 efter at de er kopierer, så sig til, den er lavet.

kabbak

OK. Men det var ikke meningen at slette linierne men blot tage en kopi som den gør. jeg er nok bare ved at blive lidt træt og udtrykker mig forkert. Det virker perfekt jeg vender tilbage i morgen hvis den ikke opfylder kravene. Jeg kan ikke teste den fuldt ud før jeg er koblet op på mit koncern netværk i morgen OK.

Hej igen
Jeg har et lille tillægs problem. jeg vil gerne have en markro mere som på samme måde kan kopierer ens linier i ark1 for rækken B over i ark4. Hele linien skal flyttes som i den første løsning.
I ark4 skal linierne listes med sorteret med ens data for rækken B under hinanden som den første markro gør. 
Eks. I ark1 celle B1 er der data som er ens med celle B10. Herefter skal hele linien 1 og hele linien 10 kopieres over i ark4 hvor de skal stå under hinanden. Det er samme problemstilling med et 15 cifret tal uden decimaler i cellerækken B.

Sidste lille rettelse er at det ikke er rækken B men rækken D der skal valideres på. Dette gælder også for den første markro. Jeg kan ikke lige se mig ud af i din kode hvordan jeg retter det.

Sub FindEnsIArk1()
Dim F As Integer, C As Integer, T As Integer, U As Integer
Worksheets("Ark4").Activate
U = 1 ' Finder ud af hvor mange rækker der er med data på ark3
Do Until Worksheets("Ark4").Cells(U, 2) = ""
U = U + 1
Loop
Worksheets("Ark1").Activate
F = 1 ' Finder ud af hvor mange rækker der er med data på ark2
Do Until Worksheets("Ark1").Cells(F, 2) = ""
F = F + 1
Loop
For T = 1 To F
Worksheets("Ark1").Activate
C = 1
Do Until Worksheets("Ark1").Cells(C, 2) = ""
If C = T Then GoTo Skift
If Worksheets("Ark1").Cells(T, 2) = Worksheets("Ark1").Cells(C, 2) Then
Worksheets("Ark1").Rows(C & ":" & C).Select
    Selection.Copy
    Sheets("Ark4").Select
    Rows(U & ":" & U).Select
    ActiveSheet.Paste
    U = U + 1
    Worksheets("Ark1").Activate
End If
Skift: ' hvis den kikker på samme celle hopper den herned
  C = C + 1
  Loop
Next T
Sheets("Ark4").Activate
Range("B1").Select
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub

Cells(F, 2) = F er en variabel for rækken og 2 er for kolonne B.

Altså ret tallet til den kolonne du vil arbejde på.

A = 1 , B= 2 , C = 3 , D = 4 osv.

det vil sige at alle steder der står Cells(?, 2) skal 2 tallet rettes til 4

og Range("B1").Select skal rettes til Range("D1").Select

Det virker fint. Vender tilbage hvis jeg får problemer. Takker.

Hej så er der kun et minimalt problem tilbage. Markroen stopper med fejl hvis der er tomme linier i rækken D, dette løste jeg ved at sætte filter på og filtrerer alle tomme linier ud af rækken D og herefter nummerer dem med løbende numre 1,2,3,4 således at de kun opstår 1 gang. Jeg ved ikke om man kunne havde programmeret sig ud af det. Løsningerne fungerer fint men kræver lidt af processoren da jeg sorterer på mellem. 1500 - 6000 linier ad gange, den kører derfor lidt langsomt, men det er jo en bagatel med mindre du kan se nogen løsning på at optimerer koden. "ud over kraftigere prosessor"

Den fungerer på den måde at den går ikke længer end til det første tomme felt den møder, det er for at gøre den hurtigere.

Hvis jeg ikke gjorde det, er der altså 65536 rækker som den skal igennen 65536 gange, og hver gang der var 2 tomme linier skal den jo udføre koperingen, for så er de jo ens, Ok det sidste kan man programere sig ud af, men den vil jo læse for langt.

Men hvis du er sikker på at dataerne ikke går længere end til eks. række 10000, så kan jeg godt stoppe den der.

Ok, Men det behøves ikke. jeg vil prøve at køre med den et stykkes tid og se om ikke det fungerer i praksis. Jeg sætter bare en ledig maskine til at udfører operationen. Jeg skal lige bruge en måned til at samle friske data.