Nieuwe sorteer functie

[smek]

Hallo allemaal,

Ik wil graag een aantal functies schrijven met een bepaald doel allereerst moet ik uit een kolom genaamt logo alle namen sorteren naar een nieuwe kolom in een nieuwe sheet. Ik wil dan ook elke naam twee keer onder elkaar zetten in de nieuwe kolom. De kolom hiervoor wil ik gaan nummeren dus de cel voor de eerste naam word 1 de volgende 2 enzovoort.
De reden dat ik een functie wil maken voor dit doel is dat de volgorde van de kolommen nogal eens wijzigen.

De Sub hieronder heb ik inmiddels gevonden en deze doet al een klein beetje wat ik wil. Maar deze moet nog worden aangepast. De kolom waar de namen in staan kan nogal eens veranderen dus dat moet aan te passen zijn.

Private Sub CommandButton1_Click()
'Deze procedure bepaalt het aantal unieke waarden in het bereik
' D5:D300 en zet deze in kolom I. In kolom J komt het
' aantal keren dat de unieke waarde is gevonden.
'Daarna wordt deze lijst in I/J gesorteerd, eerst aflopend op het
' aantal keren dat hij is gevonden en dan alfabetisch op waarde.
'Vervolgens worden deze waarden op rij 3 geplaatst vanaf kolom L
' naar rechts.
'Dit voorbeeld gaat maar tot 10 unieke waarden. Voor meer moeten
' regels code voor de kolommen I en J, en voor het tellen
' worden uitgebreid.

Dim Hier, Einde, Test, Teller, c, Chk, varTest(40) As Variant
Dim x, Teller1, Teller2, Teller3, Teller4, Teller5, Teller6, _
Teller7, Teller8, Teller9, Teller10
Dim Laatste, Sorty, i

'Hier wordt het adres van de actieve cel vastgelegd
Hier = ActiveCell.Address

'Hier wordt de opslag van unieke waarden verwijderd en de titels
' op rij 3 verwijderd
Columns("I:J").Clear
Einde = Cells(3, 12).End(xlToRight).Column
Range(Cells(3, 12), Cells(3, Einde)).Clear

'Hier worden de verschillende teksten in een matrix opgeslagen
Test = "xxx"
Teller = 0
For Each c In [A1:A300]
Chk = c.Value
If InStr(1, Test, Chk, vbTextCompare) = 0 Then
Test = Test & ", " & Chk
Teller = Teller + 1
varTest(Teller) = Chk
End If
Next

'Hier worden de verschillende teksten in kolom B ingevuld
Sheets("Resultaat").Cells(1, 2).Value = varTest(1)
Sheets("Resultaat").Cells(2, 2).Value = varTest(2)
Sheets("Resultaat").Cells(3, 2).Value = varTest(3)
Sheets("Resultaat").Cells(4, 2).Value = varTest(4)
Sheets("Resultaat").Cells(5, 2).Value = varTest(5)
Sheets("Resultaat").Cells(6, 2).Value = varTest(6)
Sheets("Resultaat").Cells(7, 2).Value = varTest(7)
Sheets("Resultaat").Cells(8, 2).Value = varTest(8)
Sheets("Resultaat").Cells(9, 2).Value = varTest(9)
Sheets("Resultaat").Cells(10, 2).Value = varTest(10)

'Hier wordt het aantal keren van elke tekst geteld
For Each x In [B1:B300]
If x = varTest(1) Then
Teller1 = Teller1 + 1
Else
If x = varTest(2) Then
Teller2 = Teller2 + 1
Else
If x = varTest(3) Then
Teller3 = Teller3 + 1
Else
If x = varTest(4) Then
Teller4 = Teller4 + 1
Else
If x = varTest(5) Then
Teller5 = Teller5 + 1
Else
If x = varTest(6) Then
Teller6 = Teller6 + 1
Else
If x = varTest(7) Then
Teller7 = Teller7 + 1
Else
If x = varTest(8) Then
Teller8 = Teller8 + 1
Else
If x = varTest(9) Then
Teller9 = Teller9 + 1
Else
If x = varTest(10) Then
Teller10 = Teller10 + 1
Else
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
Next

'Hier wordt de onderste rij van de gegevens in kolom I bepaald
Laatste = Cells(65535, 9).End(xlUp).Row

'Hier worden de gevens gesorteerd, eerst op aantal keren gevonden
' en dan waarden alfabetisch.
Sorty = "I1:J" & Laatste
Range(Sorty).Sort Key1:=Range("J1"), key2:=Range("I1")

'Hier worden de waarden op rij 3 ingevuld vanaf kolom L.
For i = 1 To Laatste
Cells(3, i + 11).Value = Cells(i, 9).Value
Next

'Hier keer je terug naar de cel die was geselecteerd toen er
' op de knop werd gedrukt
Range(Hier).Select
End Sub

De volgende stap is dat ik de waarden uit andere cellen wil gaan uitlezen en aan de namen die in de kolom logo koppel aan de waarden van de kolom die ik met de vorige stap heb gemaakt. Maar dat zal ik zelf eerst wel proberen uit te zoeken. Als ik er niet uitkom dan laat ik wel weer van me horen.

Vast bedankt!

 

[Mark xl]

Hoi smek,

Je verhaal is niet helemaal duidelijk, dus misschien is een voorbeeldbestandje wel handig
als ik zo naar je code kijk heb ik een paar tips voor je:

gebruik bijvoorbeeld

WorksheetFunction.CountIf(Range("A1:A300"), "ikzoekdit")

in plaats van de [for if if if if if ... ... end if next]

combineren met de methode

 Range(myrange).Removeduplicates

succes.

 

[smek]

Dit voorbeeld is van het internet geplukt dus niet door mij geschreven maar het laat een beetje zien wat ik wil.
Het is mijn bedoeling om unieke namen uit een kolom te selecteren en die dubbel naar een nieuwe kolom te kopieëren.
En de kolom daarvoor te nummeren daar komt het in het kort op neer. Nu zijn er tal van voorbeelden te vinden om unieke items te verplaatsen. De meest simpele versie is deze:

Sub FindUniqueValues(SourceRange As Range, TargetCell As Range)
    SourceRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=TargetCell,  Unique:=True
End Sub

Alleen wil ik deze unieke waarden twee keer onder elkaar zetten misschien met behulp van een collection oid?

 

[Mark xl]

In dat geval is de oplossing simpel

Twee keer de unieke waarden onder elkaar zetten, alles sorteren zodat alle waarden op volgorde komen te staan, en vervolgens nummeren.

 

[smek]

Op deze manier bedoel je dan neem ik aan?
Het vreemde is alleen dat de sub de eerste naam 2 keer kopieert.

Sub FindUniqueValues()
Dim SourceRange As Range
Dim TargetCell As Range

Set SourceRange = Range("A1:A10")
Set TargetCell = Range("B1:B10")
SourceRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=TargetCell, Unique:=True

Set SourceRange = Range("A1:A10")
Set TargetCell = Range("B10:B20")
SourceRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=TargetCell, Unique:=True
End Sub

Ik vind dit trouwens niet een erg handige oplossing voor het geval de grootte van de kolommen toeneemt, liefst sla ik het op in een collection om het vervolgens met een foreach lus in een nieuwe kolom te plaatsen.
Dan kan ik ook meteen de nummering regelen.

 

[Mark xl]

Kijk hier eens naar

output kolom I

Sub test()
Dim col As String
Dim r As Long
col = InputBox("In welke kolom staan de gegevens?", , "A")
Columns("I:J").ClearContents

On Error GoTo Einde:
If WorksheetFunction.CountA(Range(col & "1:" & col & "300")) <> 0 Then
    Range("J1:J300") = Range(col & "1:" & col & "300").Value
    Range("J1:J300").RemoveDuplicates Columns:=1
    r = Range("J65535").End(xlUp).Row
    Range("J" & r).Offset(1).Resize(r) = Range("J1:J" & r).Value
    Range("J1:J" & r * 2).Sort Range("J1")
    Range("I1:I" & r * 2) = "=ROW()"
    Range("I1:I" & r * 2) = Range("I1:I" & r * 2).Value
Else
    Err.Raise 1004
End If
'Selection.RemoveDuplicates Columns:=1
On Error GoTo 0

Einde:
If Err.Number <> 0 Then MsgBox "mislukt", vbCritical
End Sub

 

[smek]

Ah perfect bedankt hiervoor!

Ik heb nog niet zoveel ervaring met vba het lijkt ook niet bepaald op de andere talen waar ik wel ervaring mee heb.
Dus het is nogal zoeken en puzzelen ik heb inmiddels de andere functie wel zelf voor elkaar gekregen.

 

[smek]

Nog een vraagje ik probeer dit alles in een andere sheet te plaatsen als ik boven Columns("I:J").ClearContents Sheets("Blad2").Select neerzet lukt dit niet.
Enig idee hoe ik dat oplos?

* Edit Omdat dan de waarden uit de andere sheet niet kunnen worden geselecteerd ik snap het al.

Als ik Range("J1:J300") verander in Range("Blad2!J1:J300") werkt het ook niet.

 

[Mark xl]

Ik denk dat het zo werkt(niet getest)

Sub test()
Dim col As String
Dim r As Long
Dim sourcesheet as string, targetsheet as string
'pas dit aan aan de bladen waar je mee werkt:
sourcesheet = "blad1"
targetsheet = "blad2"

col = InputBox("In welke kolom staan de gegevens?", , "A")

On Error GoTo Einde:

If WorksheetFunction.CountA(Sheets(sourcesheet).Range(col & "1:" & col & "300")) <> 0 Then
    
    sheets(sourcesheet).Columns("I:J").ClearContents

    With Sheets(targetsheet)

        .Range("J1:J300") = Sheets(sourcesheet).Range(col & "1:" & col & "300").Value
        .Range("J1:J300").RemoveDuplicates Columns:=1
        r = .Range("J65535").End(xlUp).Row
        .Range("J" & r).Offset(1).Resize(r) = .Range("J1:J" & r).Value
        .Range("J1:J" & r * 2).Sort .Range("J1")
        .Range("I1:I" & r * 2) = "=ROW()"
        .Range("I1:I" & r * 2) = .Range("I1:I" & r * 2).Value

    End with

Else
    Err.Raise 1004
End If
'Selection.RemoveDuplicates Columns:=1
On Error GoTo 0

Einde:
If Err.Number <> 0 Then MsgBox "mislukt", vbCritical
End Sub

 

[smek]

Werkt als een trein ontzettend bedankt!