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

[Dalbos]

Goedemiddag,

 

Ik ben op het internet volgende VBA code tegengekomen voor het kopiëren van regels.

 

Het gaat om productregels waar ook een aantal staat aangegeven in veld H. Dit aantal is de verveelvoudiging van de regel.

Echter de VBA geeft een foutmelding "Fout 13 tijdens uitvoering : type komen niet met elkaar overeen".

Bij Foutopsporing is volgende regel aangeduid.

 

timesToDuplicate = CInt(Worksheets("Sheet1").Range("H" & currentRow).Value)

 

 

Wie kan mij hiermee helpen?

 

Mvg,

Peter

 

 

De routine is.

 

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("H"& 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

[alpha]

Redelijkerwijs zijn er twee mogelijkheden:

1. De celeigenschappen van kolom H staan niet ingesteld op "Algemeen".

2. In jouw bestand komt de naam Sheet1 niet voor (en dan Sheet2 ook niet waarschijnlijk).

[Dalbos]

Beste Alpha,

 

Bedankt voor je reactie. Ik heb hier naar gekeken en alles staat correct en hij blijft dezelfde fout aangeven.

Ik heb het bestand toegevoegd.

 

INVULBLAD - In Kolom A en B kopieer ik mijn inkoopregels en de overige kolommen zijn formules om gegevens uit de order regels te halen.

VERVEELVOUDIGING - Haalt de gegevens op van INVULBLAD. Hier wil ik mijn Macro starten om Kolom C (aantal) te dupliceren en in Sheet 2 te zetten.

 

Hopelijk geeft dit meer duidelijkheid en wil je hier nog een keer naar kijken.

 

Bij voorbaat dank.

 

Mvg,

Peter

 

 

Sticker.xlsm

[alpha]

Als je precies beschrijft wat de macro moet doen, dan zal ik de code herschrijven.

Als ik het goed begrijp wil je elke rij van het blad "Verveelvoudiging" naar het blad "Sheet2" kopiëren en wel elke rij zoveel keer als het getal dat in kolom C staat.

Laat aub even weten of dat juist is, en indien niet, wat er dan wél moet gebeuren.

4 september 2015 aangepast door alpha

[Dalbos]

Wat fijn dat je me wilt helpen.

Het is idd de bedoeling om 4 rijen als resultaat te krijgen als aantal 4 is. Ik heb liever dat alles in TAB Verveelvoudiging komt ipv in een nieuwe tab Sheet 2. Tenminste als dat kan.

Bij voorbaat dank

Peter

[alpha]

Bijkomende vraag:

Is het aantal in kolom C van het blad "Verveelvoudiging" altijd groter dan 0 ?

[Dalbos]

De Waarde in C is minimaal 1

[alpha]

Uitgaande van de gegevens in het invulblad zoals die er NU in je bestand uitzien, moet dus elke rij slechts 1 keer gekopieerd worden (met uitzondering van de kolommen A en B , maar een volgende keer zou dat anders kunnen zijn. Is dat juist?

4 september 2015 aangepast door alpha

[Dalbos]

inderdaad, dit zijn een paar test regels. Normaal zijn dit er 200 met elk een ander aantal. Na dupliceren worden dit dan bv 600 regels.

[alpha]

Sub kopieer()
Dim a As Integer, x As Integer, lr As Integer
Application.ScreenUpdating = False
Sheets("Verveelvoudiging").Cells.ClearContents
With Sheets("Invulblad")
.Range("a1").CurrentRegion.Offset(, 2).Copy
End With
With Sheets("Verveelvoudiging")
.Activate
With .Range("a1")
.PasteSpecial Paste:=xlPasteValues
.Select
End With
x = .Range("a1").CurrentRegion.Rows.Count
Do While x > 1
a = .Range("c" & x).Value
If a > 1 Then
.Rows(x + 1 & ":" & x + a - 1).Insert
.Rows(x & ":" & x + a - 1).FillDown
End If
x = x - 1
Loop
.Columns("a:n").AutoFit
End With
Application.ScreenUpdating = True
End Sub