Dubbele namen tellen

[HSV]

Je wilt alleen de namen die er dubbel in staan zien?

Sub hsv()
Dim oDic As Object, sn, i As Long, ii As Long, j As Long
Set oDic = CreateObject("scripting.dictionary")
  For i = 1 To Sheets.Count - 1
     sn = Sheets(i).Range("a3:a17").SpecialCells(2)
       For ii = 1 To UBound(sn)
         oDic.Item(sn(ii, 1)) = oDic.Item(sn(ii, 1)) + 1
       Next ii
   Next i
[COLOR=#FF0000]    For j = oDic.Count - 1 To 0 Step -1
      If oDic.Item(oDic.keys()(j)) = 1 Then oDic.Remove oDic.keys()(j)
    Next j[/COLOR]
 With Blad4
   .Cells(2, 1).Resize(oDic.Count, 2) = Application.Transpose(Array(oDic.keys, oDic.items))
   .Cells(1).CurrentRegion.Sort .[a1], , , , , , , 1
 End With
 End Sub

 

[adile]

Dat klopt, bij jouw zie ik de enkele ook en niet gesorteerd.

vandaar

 

[HSV]

Je kan zo te zien geen code lezen, maar je kan nog wel bestanden openen hoop ik?

 

[Timshel]

Sub tsh()
    Dim Br
    Dim Jip
    Dim Nm As String
    Dim i As Long, j As Long
    
    With CreateObject("Scripting.Dictionary")
        For i = 1 To Sheets.Count - 1
            Br = Sheets(i).Range("G5:G41")
            For j = 1 To UBound(Br)
                If InStr(Nm, Br(j, 1) & "|") > 0 Then
                    Jip = .Item(Br(j, 1))
                    If IsEmpty(Jip) Then Jip = Array("", 1)
                    .Item(Br(j, 1)) = Array(Br(j, 1), Jip(1) + 1)
                Else
                    Nm = Nm & Br(j, 1) & "|"
                End If
            Next
        Next
        If .Exists(vbNullString) Then .Remove vbNullString
        [COLOR="#FF0000"]If .Count > 0 Then Br = Application.Index(.items, 0) Else Exit Sub[/COLOR]
    End With
    With Sheets("Eindlijst")
        .Cells(1, 1).CurrentRegion.Offset(1).ClearContents
        .Cells(2, 1).Resize(UBound(Br), 2) = Br
        .Cells(1, 1).CurrentRegion.Sort .[B1], Order1:=xlDescending, Header:=xlYes
    End With
End Sub

 

[adile]

Oke in je laatste bestandje zie ik alleen de dubbele,

alleen ze zijn niet descending gesorteerd.

mijn oorspronkelijke bestand heft 53 tabbladen (weken in een jaar) waar hij de info uit moet halen.
deze info staat in G5 t/m G41.

de dubbele namen moeten naar tabblad "Eindlijst"

de dubbele namen moeten in B4 en verder naar beneden (voor zoveel het er zijn)
en het aantal keer dat de naam voorkomt moet in C4 en naar beneden.

met de code van timshel was ik een heel eind opweg, alleen geeft deze een error wanneer er geen dubbele namen zijn.

Adile

 

[HSV]

Test het maar eens.
Blad 'eindlijst' moet het laatste blad in je werkboek zijn.

Sub hsv()
Dim oDic As Object, sn, i As Long, ii As Long, j As Long
Set oDic = CreateObject("scripting.dictionary")
  For i = 1 To Sheets.Count - 1
     sn = Sheets(i).Range("g5:g41").SpecialCells(2)
       For ii = 1 To UBound(sn)
         oDic.Item(sn(ii, 1)) = oDic.Item(sn(ii, 1)) + 1
       Next ii
   Next i
    For j = oDic.Count - 1 To 0 Step -1
      If oDic.Item(oDic.keys()(j)) = 1 Then oDic.Remove oDic.keys()(j)
    Next j
 With Sheets("eindlijst")
   .Cells(4, 2).Resize(oDic.Count, 2) = Application.Transpose(Array(oDic.keys, oDic.items))
   .Cells(4, 2).CurrentRegion.Sort .[b4], 2, , , , , 1
 End With
 End Sub

 

[Timshel]

@HSV.
Je moet sorteren op kolom B.
@Adile
Check even of in post #24 alles nu werkt.

 

[HSV]

Aanpassingen uit de losse pols gedaan op forum (is blijven staan).
Alleen weet ik nog niet of het een 'header' bevat.

Edit: Of moet het nu op kolom C, omdat in B de namen komen en in C de aantallen.

 

[adile]

@ HSV Ik heb hem getest, maar ik krijg een error.

de rode lijn in de Code wordt geel.

Maar de laatste Code van Timshel heeft me uit de brand geholpen, die werkt perfect.
ik kan hem nu afsluiten omdat het bestand doet wat ik wil.

@ Timshel, HSV, Wher en Sylvester hartelijk dank voor alle hulp.

Sub hsv()
Dim oDic As Object, sn, i As Long, ii As Long, j As Long
Set oDic = CreateObject("scripting.dictionary")
  For i = 1 To Sheets.Count - 1
     [COLOR="#FF0000"]sn = Sheets(i).Range("g5:g41").SpecialCells(2)[/COLOR]
       For ii = 1 To UBound(sn)
         oDic.Item(sn(ii, 1)) = oDic.Item(sn(ii, 1)) + 1
       Next ii
   Next i
    For j = oDic.Count - 1 To 0 Step -1
      If oDic.Item(oDic.keys()(j)) = 1 Then oDic.Remove oDic.keys()(j)
    Next j
 With Sheets("Eindlijst")
   .Cells(4, 2).Resize(oDic.Count, 2) = Application.Transpose(Array(oDic.keys, oDic.items))
   .Cells(4, 2).CurrentRegion.Sort .[a1], 2, , , , , 1
 End With
 End Sub

@HSV

jij had mij met het probleem in onderstaande link een hele mooie werkende code bezorgt, weet jij hoe ik die ook kan toepassen op K, L en M?

http://www.helpmij.nl/forum/showthread.php/873087-Oorspronkelijke-formule-terugzetten?p=5617633#post5617633

Gr Adile

 

[HSV]

Dan zijn er geen cellen ingevuld waarschijnlijk in een bepaalde blad "Specialcells(2)".

Sub hsv()
Dim oDic As Object, sn, i As Long, ii As Long, j As Long
Set oDic = CreateObject("scripting.dictionary")
  For i = 1 To Sheets.Count - 1
     sn = Sheets(i).Range("g5:g41")
       For ii = 1 To UBound(sn)
         if sn(ii,1) <> "" then oDic.Item(sn(ii, 1)) = oDic.Item(sn(ii, 1)) + 1
       Next ii
   Next i
    For j = oDic.Count - 1 To 0 Step -1
      If oDic.Item(oDic.keys()(j)) = 1 Then oDic.Remove oDic.keys()(j)
    Next j
 With Sheets("eindlijst")
   .Cells(4, 2).Resize(oDic.Count, 2) = Application.Transpose(Array(oDic.keys, oDic.items))
   .Cells(4, 2).CurrentRegion.Sort .[b4], 2, , , , , 1
 End With
 End Sub

Uit je andere vraag kan ik niet opmerken dat mijn code gewenst was.

Succes er verder mee.

 

[adile]

dank je,

Ik gaf juist aan dat jouw code WEL werkt en dat de code van V en A de tijden liet staan.


Adile

 

[HSV]

Goedenavond,
@ VenA
hoewel het een warrig verhaal was, heb je toch voor elkaar gekregen wat ik wilde.
hartelijk dank daarvoor.
alleen bleven bij jouw formule soms de tijden staan, en dit was niet het geval bij de formule van HSV.

Adile

Is niet erg duidelijk lijkt me, maar ik zal er eens naar kijken.