Macro om nummering toe te voegen bij duplicate waarden

[lvanderpol]

Hallo allemaal!

Om lange teksten op te knippen in velden van 50 tekens, die onder elkaar worden geplaatst, heb ik onderstaande macro aan kunnen passen. Die werkt naar behoren. Zo wordt de inhoud van kolom A gekopiëerd over de nieuwe rijen.
Nu wil ik alleen dat in de tweede kolom van de output een sortering komt. Dus als de output 2 regels geeft, dan staat daar 1 en 2. Geeft de output 5 regels dan is de nummering in B bij die cellen 1 t/m 5.
Zie bijlage voor een voorbeeld van de data incl de macro, de output en de gewenste output.
Hopelijk heeft iemand de juiste aanvulling op de macro! Alvast bedankt!

Vriendelijke groet,

Lodewijk


**Excuus, ik realiseer me net dat de titel van de post de lading niet goed dekt, maar ik kan deze titel helaas niet wijzigen.**

 

[sylvester-ponte]

zo iets?

 

[lvanderpol]

Beste Sylvester,

De nummer werkt goed, bedankt. Wel loop ik tegen een ander probleem aan. Bij de output / 'opgeknipte' tekst worden de cellen niet opgevuld tot 50 tekens. Nu worden hele woorden naar een volgende cel verplaatst en spaties aan het begin en aan het eind van de tekst in een cel verwijderd. Beide is niet de bedoeling. Spaties moeten behouden blijven en cellen volledig opgevuld tot 50 karakters. Hoe krijg ik dit voor elkaar?

 

[VenA]

Probeer het zo eens

Sub VenA()
  ar = Sheets("Sheet1").Cells(1).CurrentRegion
  ReDim ar1(2, 0)
    For j = 2 To UBound(ar)
      For jj = 1 To Len(ar(j, 3)) Step 50
        t = UBound(ar1, 2)
        ar1(0, t) = ar(j, 1)
        ar1(1, t) = jj \ 50 + 1
        ar1(2, t) = Mid(ar(j, 3), jj, 50)
        t = t + 1
        ReDim Preserve ar1(2, t)
      Next jj
    Next j
    Sheets("Sheet1").Cells(15, 6).Resize(t, 3) = Application.Transpose(ar1)
End Sub

 

[lvanderpol]

Dat werkt goed, bedankt. Alleen lukt het mij zelf minder goed om deze code iets aan te passen. Tussen kolom A en B komen moet ik namelijk nog 2 kolommen plaatsen, die net als kolom A hun waarde gelijk houden over de nieuwe regels in de output.

 

[VenA]

Sub VenA()
  ar = Sheets("Sheet1").Cells(1).CurrentRegion
  ReDim ar1([COLOR="#FF0000"]4[/COLOR], 0)
    For j = 2 To UBound(ar)
      For jj = 1 To Len(ar(j, [COLOR="#FF0000"]5[/COLOR])) Step 50
        t = UBound(ar1, 2)
        ar1(0, t) = ar(j, 1)
        [COLOR="#FF0000"]ar1(1, t) = ar(j, 2)
        ar1(2, t) = ar(j, 3[/COLOR])
        ar1([COLOR="#FF0000"]3[/COLOR], t) = jj \ 50 + 1
        ar1([COLOR="#FF0000"]4[/COLOR], t) = Mid(ar(j, [COLOR="#FF0000"]5[/COLOR]), jj, 50)
        t = t + 1
        ReDim Preserve ar1([COLOR="#FF0000"]4[/COLOR], t)
      Next jj
    Next j
    Sheets("Sheet1").Cells(15, 6).Resize(t, [COLOR="#FF0000"]5[/COLOR]) = Application.Transpose(ar1)
End Sub

 

[lvanderpol]

Werkt perfect zo, bedankt!

 

[lvanderpol]

Nog een kleine vraag: hoe pas ik het script aan zodat deze begint o.b.v input vanaf regel 3, m.a.w. ik wil twee tekstregels bovenaan toevoegen waarop het script niet van toepassing moet zijn.

 

[VenA]

Loop eens in de VB-editor met <F8> door de code heen Zorg ervoor dat je het scherm Locals aan hebt staan, dan kan je precies zien welke variabele welke waarde op welk moment krijgt.

 

[lvanderpol]

Heb van alles geprobeerd maar blijf foutmeldingen krijgen. In feite schuift de array 2 regels naar beneden, maar krijg dit helaas niet voor elkaar

 

[VenA]

Plaats dan maar een representatief voorbeeldbestand. Want heel veel valt er niet aan te passen.

 

[lvanderpol]

Zie bijlage!

 

[VenA]

Als je de naam van een blad wijzigt, dan moet je dat ook in de code aanpassen.

Sub VenA()
  With Sheets("Uitgebreide sheet").ListObjects(1)
    ar = .DataBodyRange
    .DataBodyRange.Delete
    ReDim ar1(4, 0)
      For j = 1 To UBound(ar)
        For jj = 1 To Len(ar(j, 5)) Step 50
          t = UBound(ar1, 2)
          ar1(0, t) = ar(j, 1)
          ar1(1, t) = ar(j, 2)
          ar1(2, t) = ar(j, 3)
          ar1(3, t) = jj \ 50 + 1
          ar1(4, t) = Mid(ar(j, 5), jj, 50)
          t = t + 1
        ReDim Preserve ar1(4, t)
      Next jj
    Next j
    .ListRows.Add.Range.Resize(t, 5) = Application.Transpose(ar1)
  End With
End Sub

 

[lvanderpol]

Dat had ik ook gedaan, maar in dit voorbeeld per ongeluk niet meegenomen. De aanpassing van de array en range gaat mijn pet te boven, maar het werkt gelukkig.
Veel dank!!

 

[lvanderpol]

Goedemiddag, ben ik weer. Ik heb toch nog een aanpassing nodig die ik er zelf helaas niet in krijg.

De nummering die nu wordt toegevoegd in de vierde kolom gaat nu in stappen van 1, dus 1, 2, 3, etc. Echter moeten dit stappen worden van 10000, dus 10000, 20000, 30000.

ar1(3, t) = jj \ 50 + 1 heb ik aangepast naar ar1(3, t) = jj \ 50 + 10000, waardoor de startwaarde goed is.
Maar hij blijft verhogen met slechts 1. Ik heb vrijwel alle variabelen aangepast, helaas zonder resultaat.

 

[VenA]

(jj \ 50 + 1) * 10000

 

[lvanderpol]

:thumb: :thumb:

 

[VenA]

Had je toch echt zelf wel kunnen ontdekken.

Loop eens in de VB-editor met <F8> door de code heen Zorg ervoor dat je het scherm Locals aan hebt staan, dan kan je precies zien welke variabele welke waarde op welk moment krijgt.