Unikke datoer (kolonne A) på baggrund af maskinnummer (kolonne A)

Denne kode finder unikke datoer for maskinnr. i celle C1

Sub FindDubletter()
Dim x(100)
r = Cells(65500, 2).End(xlUp).Row
maskine = Cells(1, 3)

For t = 1 To r
If Cells(t, 2) = maskine Then t2 = t2 + 1: x(t2) = Cells(t, 1)
Next

For t = 1 To t2
For tt = t + 1 To t2 'Step 2
If x(t) = x(tt) Then x(tt) = ""
Next
Next

For t = 1 To t2
If x(t) <> "" Then y = y & vbLf & x(t): antal = antal + 1
Next

MsgBox ("Unikke datoer for maskin nr. ") & maskine & vbLf & y & vbLf & vbLf & "Antal " & antal
End Sub

Hej excelent,

Det kræver en nærmere forklaring eftersom jeg ikke kan få det til at fungere. Jeg har datoer i kolonne A og maskinnummer i kolonne B. Hvordan får jeg kodningen til at fungere? skal den køres som en makro? ja jeg er ikke nogen ekspert på det her skal jeg sige dig.

Ja det er en makro, kunne ikke lige få en formel til at virke

marker og kopier koden herfra
alt fra og med "Sub FindDubletter()" til og med "End Sub"

tilbage i din projektmappe taster du ALT+F11
vælg Module i menuen Insert
paste koden i vindue som fremkommer
tast ALT+Q for at returnere til arket
Indtast maskinnr du vil teste på i celle C1 (C1 kan ændres)
tast ALT+F8, marker "FindDubletter" og klik Afspil/Run

Resultatet leveres i en msgbox
men kan naturligvis også skrives i arket

Hej execelent,

Fantastisk det virker. Nu mangler jeg bare at koden til automatisk at give mig svaret på det totale antal unikke datoer pr maskine. Altså unikke datoer maskine 1 + antal unikke datoer maskine 2 osv.
Jeg har en maskinliste med maskinnumre fra 1-25.
Endvidere skal værdien skrives til en celle, da denne værdi indgår i en række formler.

ok så skal jeg lige vide om der skal skrives i samme ark
og om hvordan data skal skrives.
fx.
Maskine Antal Datoer.....
---------------------------------------------------
..1......4....dato dato dato dato
..2......1....dato
..3......9....dato dato dato dato dato dato dato dato dato
..4......3....dato dato dato
osv.
eller hvordan ?

Resultatet kunne se således ud
Maskine        Unikke datoer
1                  3 
2                  2 
3                  5 
4                  1
.
.
25                4

Resultater skal skrives i samme ark.
Håber det hjælper dig.

Prøv om denne dur.
OBS hvis du kører koden flere gange, skal område slettes først
sig til hvis dette skal indføjes i koden, og hvilket område
der i såfald skal slettes.

Sub FindDubletter()
Dim x(100), z(100)
r = Cells(65500, 2).End(xlUp).Row

For maskine = 1 To 25

For t = 1 To r
If Cells(t, 2) = maskine Then t2 = t2 + 1: x(t2) = Cells(t, 1)
Next

For t = 1 To t2
For tt = t + 1 To t2 'Step 2
If x(t) = x(tt) Then x(tt) = ""
Next
Next

For t = 1 To t2
If x(t) <> "" Then y = y & vbLf & x(t): antal = antal + 1: z(antal) = x(t)
Next

Cells(Cells(100, 4).End(xlUp).Row + 1, 4) = maskine
Cells(Cells(100, 5).End(xlUp).Row + 1, 5) = antal

'Følgende 3 linier skriver datoer hvis du får behov for det
'For t = 1 To antal
'Cells(1 + maskine, t + 5) = z(t)
'Next

'MsgBox ("Unikke datoer for maskin nr. ") & maskine & vbLf & Y & vbLf & vbLf & "Antal " & antal
Erase x, z: y = 0: t2 = 0: antal = 0
Next
End Sub

?

Hvordan går det ?

marker box med navn og klik accepter

husk lige at lukke
marker box med navn og klik accepter