dubbel waarden vinden op basis van kolom titel (bijna klaar met code :-)

[sonvnn]

Dag Allemaal

Ik zit met een probleem waar ik niet uitkom:
Wat ik wil is het volgende: Zoeken naar dubbele waarden in een kolom in de sheet Facturen op basis van de kolom titel (Product) en deze dan in een sheet kopieren ( verzamel)

On de onderstaande wordt de sheet verzamel aangemaakt en gezocht naar de kolom met de titel Product, dit gaat allemaal goed.

Waar ik niet uitkom is het volgende waarbij K staat voor de Kolom maar hier moet ik dus rng1 in zien te verwerken,
Mijn vba kennis is hier niet toereikend voor.

Iemand ? alvast dank !


For i = 2 To lastRow
If Len(Cells(i, "K")) <> 0 Then
dictionary.Add Cells(i, "K").Value, 1
End If
Next

Sub SamenvoegenProducten()

Application.ScreenUpdating = False
Dim lastRow As Long
Dim i As Long
Dim dictionary As Object
Set dictionary = CreateObject("scripting.dictionary")



'aanmaken van sheet verzamel
Dim wsTest As Worksheet
Const strSheetName As String = "Verzamel"

Set wsTest = Nothing
On Error Resume Next
Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
On Error GoTo 0
 
If wsTest Is Nothing Then
    Worksheets.Add.Name = strSheetName
End If
'einde van aanmaken sheet verzamel


Worksheets("Facturen").Activate
lastRow = Worksheets("Facturen").Cells(Rows.Count, "J").End(xlUp).Row


'In de kolommen de titel Product zoeken


   Dim ws As Worksheet
    Dim lRow As Long
    Dim aCell As Range, rng1 As Range

    '~~> Set this to the relevant worksheet
    Set ws = ActiveWorkbook.Worksheets("Facturen")

    With ws
        '~~> Find the cell which has the name
        Set aCell = .Range("A1:Z1").Find("Product")

        '~~> If the cell is found
        If Not aCell Is Nothing Then
            '~~> Get the last row in that column and check if the last row is > 1
            lRow = .Range(Split(.Cells(, aCell.Column).Address, "$")(1) & .Rows.Count).End(xlUp).Row

            If lRow > 1 Then
                '~~> Set your Range
                Set rng1 = .Range(aCell.Offset(1), .Cells(lRow, aCell.Column))

                '~~> This will give you the address
                Debug.Print rng1.Address
            End If
        End If
         End With

' Einde zoeken

On Error Resume Next



'Hier zit het probleem

For i = 2 To lastRow
    If Len(Cells(i, "K")) <> 0 Then
        dictionary.Add Cells(i, "K").Value, 1
    End If
Next

'Einde probleem


Worksheets("Verzamel").Range("A1").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)

Application.ScreenUpdating = True
MsgBox dictionary.Count & " unique cell(s) were found and copied."


End Sub

 

[HSV]

Test het zo eens.

Resultaat in het tweede blad.

Sub hsv()
Dim sn, i As Long, ii As Long, c As Range, n As Long
With Sheets("verzamel")
Set c = .Range("A1:Z1").Find("product")
If Not c Is Nothing Then
sn = .Range(.Cells(1, c.Column), .Cells(Rows.Count, c.Column).End(xlUp))
 With CreateObject("scripting.dictionary")
   For i = 1 To UBound(sn)
      If Trim(sn(i, 1)) <> "" Then .Item(sn(i, 1)) = .Item(sn(i, 1)) + 1
   Next i
     For ii = .Count - 1 To 0 Step -1
       If .Item(.keys()(ii)) > 1 Then
         .Item(ii) = .keys()(ii)
          n = n + 1
       Else
         .Remove .keys()(ii)
       End If
     Next ii
   Sheets(2).Cells(1).Resize(n) = Application.Transpose(.keys)
  End With
 End If
End With
End Sub

 

[snb]

Plaats eens een bestand met begin- en gewenste eindsituatie.

Het gebruik van autofilter of advancedfilter lijkt me voor de hand liggender.

 

[sonvnn]

bestandje

Dank voor jullie hulp !

even een verduidelijking

Waarom ik dit in vba wil doen is omdat de kolom met de titel Product niet in elk bestand hetzelfde is, dus soms is dit kolom K maar soms ook P. Wil ik dus een ontdubbeling van de Kolom met de titel Product doen dan kan ik niet "hard"verwijzen naar een kolom letter maar wel naar de titel (header) daarnaast wil ik in de verzamel sheet, nadat de ontdubbeling is gedaan met sommen.als het totaalbedrag van elk product verzamelen.