Regel invoegen als 4 = B

[HWV]

Beste,

Ik ben bezig met een bestand waar ik bij bepaalde regels een kopie van die regel wil hebben met B- ervoor.

Om een regel onder die regel te plaatsen heb ik de volgende code:

Sub Invoegen()
For i = 1 To 8000
If Cells(i, 4) = "B" Then
Cells(i + 1, 1).EntireRow.Rows.Insert
End If
Next i
End Sub

Hier kijkt hij in kolom 4 of er een B achter het artikel staat , zo ja een lege regel eronder toevoegen.

Tot zo ver is het mij gelukt.

Nu wl ik nog van de regel met de B er achter een kopie maken en deze plaatsen in de lege regel er onder maar dan wel incl de B- in het artikelnummer er bij.
Het is de bedoeling dat de gehele regel gekopieerd gaat worden.
In het voorbeeld heb ik mijn vraag neergezet zoals het nu is en hoe ik het graag zou willen hebben.

Het gaat hier om een artikelbestand van 8000 regels waar ongeveer 3000 regels tussen zitten waar dit van toepassing is dus vandaar dat ik het via VBA wil doen

Hopende dat jullie mij hier mee kunnen helpen.

Hoe het is :

Help001   Hemdtassen bedrukt "Helpmij.nl" 27/6*48cm   2000   B

en hoe het moet worden :

    Help001   Hemdtassen bedrukt "Helpmij.nl" 27/6*48cm   2000   B
B-Help001   Hemdtassen bedrukt "Helpmij.nl" 27/6*48cm   2000

Groet HWV

 

[Thoralf]

Hallo HWV,

Er zullen ongetwijfeld betere oplossingen bestaan, maar deze werkt.

 

[HierEnNu]

Een opmerking: als je bestand uit 8000 regels bestaat, dan neemt het aantal regels toe met het aantal regels dat wordt ingevoegd. Dus uiteindelijk is je bestand bv 8200 regels. Hiermee moet je rekening houden.

Groeten,

M.

 

[HWV]

Opgelost

Beste Thoralf

Bedankt voor de oplossing, ik kan hier verder mee.

Bedankt voor het meedenken.

Groet HWV

 

[HWV]

Meerde kolomen tegelijk

Ik had iets te vroeg de vraag op opgelost gezet.

Ik loop tegen het volgende aan, waar ik niet duidelijk in ben geweest in mijn vraagstelling.
Ik heb meerdere kolomen die ik wil mee kopieren en somige kolomen niet.

Moet ik dan alle kolomen per stuk defineren of kan ik dit met een range achter elkaar doen

A t/m C ; V t/m AJ ; AL t/m AO enzo nog enkele kolomen

Sub Invoegen()
For i = 1 To 9000
If Cells(i, 4) = "B" Then
Cells(i + 1, 1).EntireRow.Rows.Insert
Cells(i + 1, 1).Value = "B-" & Cells(i, 1).Value
Cells(i + 1, 2).Value = Cells(i, 2).Value
Cells(i + 1, 3).Value = Cells(i, 3).Value
End If
Next i
End Sub

 

[Thoralf]

Hallo Hwv,

Vervang de code door

Sub Invoegen()

Application.ScreenUpdating = False

For i = 1 To 9000
If Cells(i, 4) = "B" Then
Cells(i + 1, 1).EntireRow.Rows.Insert

Range("A" & i, "C" & i).Copy Destination:=Range("A" & i + 1, "C" & i + 1)
Range("V" & i, "AJ" & i).Copy Destination:=Range("V" & i + 1, "AJ" & i + 1)
Range("AL" & i, "AO" & i).Copy Destination:=Range("AL" & i + 1, "AO" & i + 1)

Cells(i + 1, 1).Value = "B-" & Cells(i, 1).Value

End If
Next i

Application.ScreenUpdating = True

End Sub

 

[HWV]

Bedankt

Dit is de oplossing voor mijn probleem.
Mijn dank hiervoor

Groet HWV