Teller werkt niet helemaal juist

[DarkValley]

Beste Vba'ers

Het lukt me niet geheel om een teller juist te implementeren in een stukje code. Ik hoop dat iemand mijn kan helpen.
De teller moet als volgt werken. Als ARTNR gelijk is ARTNR in de cel erboven en het MERK is ook gelijk dan moet het MERK in huidige rij worden vervangen door huidige celwaarde + teller


beginbestand:




hoe het nu eruit komt te zien:




Hoe het er eigenlijk uit zou moeten zien :

Sub TESTTESTTEST()
 
 Range("A2").Select
  
  Range(Selection, Selection.End(xlToRight)).Select
  Range(Selection, Selection.End(xlDown)).Select
  
  Dim iRows As Long, ir As Long
  Dim WithWhat As Variant

   iRows = Selection.Rows.Count
     
       For ir = 1 To iRows
      
       WithWhat = Selection.Item(ir, 1).Value
       check2 = Selection.Item(ir, 3).Value
     
      If Selection.Item(ir, 1).Value = Selection.Item(ir - 1, 1).Value Then                         'is bovenliggend artikelnummer gelijk
       
      tel = 0                                                                                       'set teller op nul
    
     Do
     
         If Selection.Item(ir, 3).Value = check2 And Selection.Item(ir, 1).Value = WithWhat Then    'merk gelijk en artikelnummer gelijk
            
         Selection.Item(ir, 3).Value = check2 & IIf(tel = 0, "", "(" & tel & ")")                   'waarde vervangen door check2 + teller
         tel = tel + 1                                                                              'teller ophogen
         ir = ir + 1                                                                                'rij ophogen
       Else
         tel = 0                                                                                    'set teller op nul om uit loop te komen
         ir = ir - 1                                                                                'één rij terug anders wordt niet alle data gecheckt
     End If
         
  Loop While tel <> 0
        
   Else
       
  End If

Next ir
 
End Sub

Ik hoop dat iemand mij kan helpen.

Bron bestand:

Bekijk bijlage test cross.xlsm

 

[edmoor]

Probeer deze eens:

Sub Tellen()
    For i = 2 To Cells(1).CurrentRegion.Rows.Count
        Merk = IIf(teller > 0, Cells(i + 1, 3), Cells(i, 3))
        If Cells(i + 1, 1) = Cells(i, 1) And Cells(i + 1, 3) = Merk Then
            teller = teller + 1
            Cells(i + 1, 3).Value = Merk & "(" & teller & ")"
        Else
            teller = 0
        End If
    Next i
End Sub

Ik heb wel eerst de gegevens in je document gelijk gemaakt aan je derde plaatje.
Uiteraard zonder de teller informatie, dus alleen het MERK.

 

[DarkValley]

Dit werkt perfect!!:thumb:

ik ga hier meteen mee verder en kijken of dit op een groter bereik ook zo lekker snel gaat. Nogmaals bedankt @Edmoor voor jou hulp.

Echt knap hoor, met een relatief klein stukje code het probleem opgelost.

thnx

 

[DarkValley]

Beste Edmoor,

Na deze kleine aanpassing werkt het. Door naar de regel erboven te kijken doet het wat het moet doen.

Bedankt voor jouw opzet en richting.

Sub Tellen()
    For i = 2 To Cells(1).CurrentRegion.Rows.Count
        Merk = IIf(teller > 0, Cells(i + 1, 3), Cells(i, 3))
        If Cells(i - 1, 1) = Cells(i, 1) And Cells(i - 1, 3) = Merk Then
            teller = teller + 1
            Cells(i, 3).Value = Merk & "(" & teller & ")"
        Else
            teller = 0
        End If
    Next i
End Sub

 

[DarkValley]

beste Edmoor,

het werkt toch nog niet naar behoren.


ik moet toch iets maken waardoor totdat ARTNR en MERK gelijk zijn het MERK wordt vergeleken met de eerste gelijke MERK en dan de teller toegevoegd word.

dus op deze manier:

SRT
SRT(1)
SRT(2)
SRT(3)
SRT(4)
etc...
etc....


Nu maakt hij bij dubbele (1), (2) etc aan maar het kan ook zijn dat er helemaal geen dubbele zijn en dan krijg je dus SRT. Probleem is dat ik hiervan via code een zeg maar matrix tabel maak


uiteindelijk dus ongeveer op deze manier gepresenteerd:

KOLOM A KOLOM B KOLOM C KOLOM D etc.. etc...

ARTNR SRT SRT(1) SRT(2)

QRS1000 nummer nummer nummer

etc

etc

e

 

[DarkValley]

Misschien niet helemaal eerlijk op deze manier maar het lijkt te werken op deze manier.

Sub Tellen()
    For i = 2 To Cells(1).CurrentRegion.Rows.Count
      
        merk = IIf(teller > 0, Cells(i - teller, 3), Cells(i, 3))
        If Cells(i - 1, 1) = Cells(i, 1) And Cells(i - teller, 3) = merk Then
            teller = teller + 1
         If teller = 1 Then
          GoTo volgende
          Else
       End If
         
          Cells(i, 3).Value = merk & "(" & teller - 1 & ")"
        Else
            teller = 0
       
        End If
volgende:
    Next i
End Sub

morgen maar weer ff verder testen.

 

[HSV]

Test het eens.

Het resultaat in kolom J en verder.

Sub hsv()
Dim sv, i As Long
sv = Cells(1).CurrentRegion
With CreateObject("scripting.dictionary")
    For i = 1 To UBound(sv)
      .Item(sv(i, 1) & sv(i, 3)) = .Item(sv(i, 1) & sv(i, 3)) + 1
      sv(i, 3) = IIf(.Item(sv(i, 1) & sv(i, 3)) = 1, sv(i, 3), sv(i, 3) & " (" & .Item(sv(i, 1) & sv(i, 3)) - 1 & ")")
    Next
  End With
 Cells(1, 10).Resize(UBound(sv), 3) = sv
End Sub

Of:

    sv(i, 3) = sv(i, 3) & IIf(.Item(sv(i, 1) & sv(i, 3)) = 1, "", " (" & .Item(sv(i, 1) & sv(i, 3)) - 1 & ")")

 

[DarkValley]

Beste HSV,

Dit werkt bijna perfect.

Alleen hoe kan ik zorgen dat alles ook altijd in tekst formaat blijft zoals de oorsprong.

Probleem is namelijk dat er soms een 0 staat voor een nummer en deze is deel van het nummer dus moet als tekst worden gezien.

 

[emields]

wees slim en plaats een voorbeeldbestand.

 

[DarkValley]

Hi Emields,

Was ik al. Zie eerste post

 

[HSV]

Sub hsv()
Dim sv, i As Long
sv = Cells(1).CurrentRegion
With CreateObject("scripting.dictionary")
    For i = 1 To UBound(sv)
      .Item(sv(i, 1) & sv(i, 3)) = .Item(sv(i, 1) & sv(i, 3)) + 1
      sv(i, 3) = sv(i, 3) & IIf(.Item(sv(i, 1) & sv(i, 3)) = 1, "", " (" & .Item(sv(i, 1) & sv(i, 3)) - 1 & ")")
    Next
  End With
  With Cells(1, 10).Resize(UBound(sv), 3)
  .NumberFormat = "@"
  .Value = sv
 End With
End Sub

 

[DarkValley]

Bedankt Harry voor de hulp. Dit werkt perfect.

@Edmoor, ik zal kijken of ik van jou ook nog kan aanpassen zodat deze goed werkt. thnx