Finde unikke værdier i liste

Sorter kolonne A stigende og kør så makroen.

Sub Find_Unikke()
l = Range("A65536").End(xlUp).Address
For Each C In Range("A1:" & l).Cells
If C <> C.Offset(1, 0) Then
If Range("D1") <> "" Then
Range("D65536").End(xlUp).Offset(1, 0) = C
Else
Range("D1") = C
End If
End If
Next
End Sub

Det er faktisk meget simpelt...
Marker en celle i den liste med gengangere.

Vælg Data -> Filter -> Avanceret filter

Vælg kopier til ny Lokation, sæt hak i Unikke poster og vælg det sted der skal kopiers til.

Du skal dog være opmærksom på at der skal være en overskrift på kolonnen....ellers bruger den den første værdi som kolonneoverskrift..

/Martin

knowit> Jeg må nok sige at kabbak's løsning er lidt smartere for mig i det her tilfælde da jeg i forvejen kører en længere VBA smøre for at få disse tal
Tallene er årstal hevet ud af filnavnet på en masse datafiler jeg finder med en FileSearch

kabbak> 1 svar = points

Det er bare i orden.....

/Martin

et svar :-))

knowit> Du skal også have lidt for dit input

knowit> du får også lidt for dit input

Jeg vil så lige komme med en kommentar til programmet...

Det kan gøres lidt nemmere :

Function uniqueValues(rngSourceRange as range, rngTargetRange as range) as boolean

on error goto errorhandler
    rngSourceRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rngTargetRange, unique:=True

uniqueValues=true
exit function

errorhandler:
uniqueValues=false

End function

Du skal så kalde funktionen med et kald som indeholder din kildeområde og dit målområde :

    If uniqueValues(Range(Cells(1, 1), Cells(1, 1).end(xlDown)), Cells(5, 1)) Then
        'Kode til at bekræfte sortering
    Else
        'Kode til at afkræfte at sortering lykkedes
    End If

Lille rettelse til programmet :

Function uniqueValues(rngSourceRange, rngTargetRange) As Boolean

On Error GoTo errorhandler
   
    Range(rngSourceRange).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range(rngTargetRange), Unique:=True
   
uniqueValues = True

Exit Function

errorhandler:

uniqueValues = False

End Function


Sub TEst()

    If uniqueValues("A1:A11", "D4") Then
        MsgBox "OK"
    Else
        MsgBox "Not ok"
    End If
   

End Sub

Jeg har nu lavet nedenstående funktion (er ikke helt færdig endnu), men når jeg tester med f.eks. 4 filer der hedder 2004-xxxx.tld, så finder den 2 værdier med 2004 i begge.
Hvis jeg så putter en fil ind fra et andet årstal, så fungerer det tilsyneladende som det skal.

Public Function fhpPayment_Find_Years() As Integer
' -----------------------------------------------------------------------------------
' Purpose    : Finder årstal fra gemte data
' Parameters :
' Returns    : Integer
' Created    : 05-20-04
' Modified  :
' Remarks    :
' -----------------------------------------------------------------------------------
On Error GoTo Error_fhpPayment_Find_Years
  Dim strFolder As String
  Dim lngFiles As Integer
  Dim fsObj
 
  Set fsObj = CreateObject("Scripting.FileSystemObject")
  Application.StatusBar = "Finder årstal. Vent venligst......"
  Sheets(conHiddenSheet).Range("D2:E65536").ClearContents
 
  strFolder = fhpPayment_Folder_Name(conTAXA)
 
  Application.Cursor = xlWait
  With Application.FileSearch
    .NewSearch
    .LookIn = strFolder
    .SearchSubFolders = True
    .Filename = "*" & conDatExt
    .MatchTextExactly = False
    .Execute
    If .FoundFiles.Count > 0 Then
      For lngFiles = 1 To .FoundFiles.Count
        Worksheets(conHiddenSheet).Cells(lngFiles + 1, 4).Value = Left(fsObj.GetBaseName(.FoundFiles(lngFiles)), 4)
      Next lngFiles
      Worksheets(conHiddenSheet).Range("D2:D65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Worksheets(conHiddenSheet).Range("E2"), unique:=True
    End If
  End With

Exit_fhpPayment_Find_Years:
  Application.Cursor = xlDefault
  Set fsObj = Nothing
  Application.StatusBar = ""
  Exit Function

Error_fhpPayment_Find_Years:
  Select Case Err.Number
    Case 2501
    Case 3021
    Case Is < 0
    Case Else
      MsgBox Err.Number & ": " & Err.Description, vbOKOnly + vbCritical, "Error in procedure 'fhpPayment_Find_Years'"
  End Select
  Resume Exit_fhpPayment_Find_Years

End Function

Du skal huske at der skal være overskift i kolonnen som du skal sortere, ellers opfattes den første værdi i listen (D2) som overskrift på kolonnen....

Jeg vil tro at linjen

Worksheets(conHiddenSheet).Range("D2:D65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Worksheets(conHiddenSheet).Range("E2"), unique:=True

skal rettes til

Worksheets(conHiddenSheet).Range("D1:D65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Worksheets(conHiddenSheet).Range("E1"), unique:=True


/Martin

Det ser ud til at det var det der skulle til.

Tak