Excel vba macro om rijen te kopiëren gebaseerd op de waarde van een cell

excel
Excel

Deze is alleen voor de Excel-nerds onder ons!

Om data van DUO klaar te maken voor Fineo (voor mijn visualisatie van doorstroom PO-VO), moest ik rijen dupliceren. De data zegt bijvoorbeeld dat van school X er 3 leerlingen naar school Y gaan. Dan is het nodig voor Sankey diagrammen dat de stroom van school X naar school Y 3x vermeld wordt.

Nu bevatte het bestand zo'n 47.000 records. Dus handmatig dit doen, is niet te doen. Ik vond een macro die het volgende kan:

  • Zoek op werkblad 1 in rij 1 en kolom X naar een waarde. (In dit geval het aantal leerlingen dat doorstroomt.)
  • Kopieer op werkblad 2 deze rij precies zo vaak als de gevonden waarde.
  • Ga door voor de volgende rij op werkblad 1.

De code klopte alleen niet meer helemaal voor de huidige Office versie en werkte ook niet met grote aantallen records. Hieronder mijn versie:

[code lang="vb"]
Sub DuplicateRows()
Dim currentRow As Long
Dim currentNewSheetRow As Long: currentNewSheetRow = 1

For currentRow = 1 To 32768 'The last row of your data
Dim timesToDuplicate As Integer
timesToDuplicate = CInt(Worksheets("Sheet1").Range("J" & currentRow).Value)
Dim i As Integer
For i = 1 To timesToDuplicate
Worksheets("Sheet2").Range("A" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("A" & currentRow).Value
Worksheets("Sheet2").Range("B" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("B" & currentRow).Value
Worksheets("Sheet2").Range("C" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("C" & currentRow).Value
Worksheets("Sheet2").Range("D" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("D" & currentRow).Value
Worksheets("Sheet2").Range("E" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("E" & currentRow).Value
Worksheets("Sheet2").Range("F" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("F" & currentRow).Value
Worksheets("Sheet2").Range("G" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("G" & currentRow).Value
Worksheets("Sheet2").Range("H" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("H" & currentRow).Value
Worksheets("Sheet2").Range("I" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("I" & currentRow).Value
currentNewSheetRow = currentNewSheetRow + 1
Next i
Next currentRow
End Sub
[/code]

Om dit voor andere bestanden te gebruiken, moet de code andere waardes hebben voor het maximale aantal rijen, de kolom waar op gezocht wordt (hier was dat "J") en het aantal velden dat gekopieerd moet worden.