• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Bij waarde TRUE automatisch een regel kopieeren en tussenvoegen (zelfde inhoud)

Status
Niet open voor verdere reacties.
I

Inkie64

Gebruiker
Lid geworden
5 nov 2007
Berichten
14
Hallo,

Ik heb een bestand met in kolom D artikelnummers waar soms 2 codes zijn ingevuld. Kenmerk is een komma, als de waarde een komma heeft staat in kolom TRUE. Dan moet de hele regel gekopieerd worden en onder die regel worden tussengevoegd.
Vervolgens kan ik dan de positie van de komma gebruiken om de tekst te trimmen, links en rechts, dat gaat me wel lukken.

Wie kan mij helpen? Alvast bedankt.
 

Bijlagen

Op basis van de komma in kolom D

Code: 
Sub CopyRowsWithComma()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Set ws = ActiveSheet

    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

    For i = lastRow To 1 Step -1
        If InStr(ws.Cells(i, 4).Value, ",") > 0 Then
            ws.Rows(i + 1).Insert Shift:=xlDown
            ws.Rows(i).Copy Destination:=ws.Rows(i + 1)
        End If
    Next i
End Sub

Deze past ook de artikelen aan Trimmen op basis van komma.

Code: 
Sub CopyRowsWithComma()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim commaPos As Long

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

    For i = lastRow To 1 Step -1
        If InStr(ws.Cells(i, 4).Value, ",") > 0 Then
            commaPos = InStr(ws.Cells(i, 4).Value, ",")
            ws.Rows(i + 1).Insert Shift:=xlDown
            ws.Rows(i).Copy Destination:=ws.Rows(i + 1)
            ws.Cells(i, 4).Value = Left(ws.Cells(i, 4).Value, commaPos - 1)
            ws.Cells(i + 1, 4).Value = Mid(ws.Cells(i + 1, 4).Value, commaPos + 1)
            ws.Cells(i, 4).Value = Replace(ws.Cells(i, 4).Value, ",", "")
            ws.Cells(i + 1, 4).Value = Replace(ws.Cells(i + 1, 4).Value, ",", "")
        End If
    Next i
End Sub
 
Laatst bewerkt:
Enigmasmurf zei:
Op de knop klikken doet vermoedelijk (hopelijk?) precies wat je wil. De kolom met TRUE heb je daarvoor niet eens nodig.
Klik om te vergroten...
Dit werkt helemaal goed! Ik kan de code niet zien, mijn echte bestand is veel groter, van kolom "A" tm kolom "AE" en heeft meer dan 17000 regels. De komma is te vinden in kolom "K". Mag ik je om de code vragen?
1000x dank!
 
Alt F11

en dit is zijn macro

Code: 
Sub splitsen()
r = 2
While Cells(r, 1) <> ""
  If InStr(Cells(r, 4), ",") Then
    Rows(r).Copy
    Rows(r + 1).Insert
    art = Split(Cells(r, 4), ",")
    Cells(r, 4) = Trim(art(0))
    Cells(r + 1, 4) = Trim(art(1))
  End If
  r = r + 1
Wend
Application.CutCopyMode = False
End Sub
 
Inkie64 zei:
1000x dank!
Klik om te vergroten...
1000? Dat is echt veel te veel, hoor!
De code heb je inmiddels gevonden (?)
Je ziet er een paar keer '4' in staan. Die staat voor kolom D, dus voor kolom K even vervangen door '11'.
Tenslotte: voor 17000 regels kan ik je enkel adviseren om als eerste regel in de code te zetten:
Code: 
Application.ScreenUpdating = False
Dat zal de snelheid ten goede komen. Succes !
 
Obrecht zei:
Op basis van de komma in kolom D

Code: 
Sub CopyRowsWithComma()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Set ws = ActiveSheet

    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

    For i = lastRow To 1 Step -1
        If InStr(ws.Cells(i, 4).Value, ",") > 0 Then
            ws.Rows(i + 1).Insert Shift:=xlDown
            ws.Rows(i).Copy Destination:=ws.Rows(i + 1)
        End If
    Next i
End Sub

Deze past ook de artikelen aan Trimmen op basis van komma.

Code: 
Sub CopyRowsWithComma()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim commaPos As Long

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

    For i = lastRow To 1 Step -1
        If InStr(ws.Cells(i, 4).Value, ",") > 0 Then
            commaPos = InStr(ws.Cells(i, 4).Value, ",")
            ws.Rows(i + 1).Insert Shift:=xlDown
            ws.Rows(i).Copy Destination:=ws.Rows(i + 1)
            ws.Cells(i, 4).Value = Left(ws.Cells(i, 4).Value, commaPos - 1)
            ws.Cells(i + 1, 4).Value = Mid(ws.Cells(i + 1, 4).Value, commaPos + 1)
            ws.Cells(i, 4).Value = Replace(ws.Cells(i, 4).Value, ",", "")
            ws.Cells(i + 1, 4).Value = Replace(ws.Cells(i + 1, 4).Value, ",", "")
        End If
    Next i
End Sub[
[/QUOTE]
Klik om te vergroten...

Obrecht zei:
Op basis van de komma in kolom D

Code: 
Sub CopyRowsWithComma()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Set ws = ActiveSheet

    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

    For i = lastRow To 1 Step -1
        If InStr(ws.Cells(i, 4).Value, ",") > 0 Then
            ws.Rows(i + 1).Insert Shift:=xlDown
            ws.Rows(i).Copy Destination:=ws.Rows(i + 1)
        End If
    Next i
End Sub

Deze past ook de artikelen aan Trimmen op basis van komma.

Code: 
Sub CopyRowsWithComma()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim commaPos As Long

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

    For i = lastRow To 1 Step -1
        If InStr(ws.Cells(i, 4).Value, ",") > 0 Then
            commaPos = InStr(ws.Cells(i, 4).Value, ",")
            ws.Rows(i + 1).Insert Shift:=xlDown
            ws.Rows(i).Copy Destination:=ws.Rows(i + 1)
            ws.Cells(i, 4).Value = Left(ws.Cells(i, 4).Value, commaPos - 1)
            ws.Cells(i + 1, 4).Value = Mid(ws.Cells(i + 1, 4).Value, commaPos + 1)
            ws.Cells(i, 4).Value = Replace(ws.Cells(i, 4).Value, ",", "")
            ws.Cells(i + 1, 4).Value = Replace(ws.Cells(i + 1, 4).Value, ",", "")
        End If
    Next i
End Sub
Klik om te vergroten...
Dit werkt ook, dankjewel @Obrecht
 
Enigmasmurf zei:
1000? Dat is echt veel te veel, hoor!
De code heb je inmiddels gevonden (?)
Je ziet er een paar keer '4' in staan. Die staat voor kolom D, dus voor kolom K even vervangen door '11'.
Tenslotte: voor 17000 regels kan ik je enkel adviseren om als eerste regel in de code te zetten:
Code: 
Application.ScreenUpdating = False
Dat zal de snelheid ten goede komen. Succes !
Klik om te vergroten...
Jaren geleden schreef ik macro's, ben vastgeroest maar vind het wel weer erg leuk! En dan is 1000x dank niets hoor ;-).
 
Komt dit in de buurt v.w.b. je voorbeeld in je eerste vraag?
Geen VBA maar met power query.
Dat is ook heel handig aangezien je >17000 regels hebt.
 

Bijlagen

@ peter59,
Toen ik je naam zag verschijnen wist ik het: hier volgt een PQ-oplossing;)
Ik heb mijn vorige code nog lichtjes aangepast en ze verwerkt 17000 rijen in net geen 2 seconden. Zelf (maar wie ben ik) zou ik daar niet wakker van liggen.
Dat gezegd zijnde: ik wil vooral geen afbreuk doen aan je PQ-methode, integendeel👍
Rekening houdend met de mogelijkheid dat Ingrid het toch liever bij VBA houdt:
Code: 
Sub splitsen()
Application.ScreenUpdating = False
r = 2
While Cells(r, 1) <> ""
  If InStr(Cells(r, 4), ",") Then
    Rows(r + 1).Insert
    Cells(r + 1, 1).Resize(, 4).Value = Cells(r, 1).Resize(, 4).Value
    art = Split(Cells(r, 4), ",")
    Cells(r, 4) = Trim(art(0))
    Cells(r + 1, 4) = Trim(art(1))
  End If
  r = r + 1
Wend
Application.CutCopyMode = False
End Sub
 
Je kunt de Macro van Enigmasmurf ook zo aanpassen
dan is het duidelijk om welke kolommen het gaat.

Code: 
Sub splitsen()
    Application.ScreenUpdating = False
    r = 2
    While Cells(r, "A").Value <> ""
        If InStr(Cells(r, "D"), ",") Then
            Rows(r + 1).Insert
            Cells(r + 1, "A").Resize(, 4).Value = Cells(r, "A").Resize(, 4).Value
            art = Split(Cells(r, "D"), ",")
            Cells(r, "D") = Trim(art(0))
            Cells(r + 1, "D") = Trim(art(1))
        End If
        r = r + 1
    Wend
    Application.CutCopyMode = False
End Sub
 
Hoe minder interactie in het werkblad hoe sneller.
17000 rijen → 0.2 seconden.
Code: 
Sub CopyRowsWithComma()
Dim sv, sn, sq, st, i As Long, j As Long, jj As Long, n As Long, x As Long, r As Long
 sv = Cells(1).CurrentRegion
  st = UBound(sv) + Application.CountIf(Columns(4), "*,*")
ReDim sn(st, 4)
For i = 1 To UBound(sv)
 If InStr(sv(i, 4), ",") Then
   sq = Split(sv(i, 4), ", ")
    For j = 0 To UBound(sq)
      For jj = 1 To 3
         sn(n, jj - 1) = sv(i, jj)
       Next jj
     sn(n, 3) = sq(j)
            n = n + 1
            r = 1
    Next j
   Else
    For x = 1 To 4
     sn(n, x - 1) = sv(i, x)
    Next x
  End If
If r = 0 Then n = n + 1
  r = 0
Next i
With Cells(1, 7)
 .CurrentRegion.ClearContents
 .Resize(st, 4) = sn
End With
End Sub
 
Toch nog maar een stukje korter.
Code: 
Sub CopyRowsWithComma()
Dim sv, sn, sq, st, i As Long, j As Long, jj As Long, n As Long, r As Long
 sv = Cells(1).CurrentRegion
 st = UBound(sv) + Application.CountIf(Columns(4), "*,*")
ReDim sn(st, 3)
For i = 1 To UBound(sv)
   sq = Split(sv(i, 4), ", ")
    For j = 0 To UBound(sq)
      For jj = 1 To 3
         sn(n, jj - 1) = sv(i, jj)
       Next jj
     sn(n, 3) = sq(j)
            n = n + 1
            r = 1
    Next j
  If r = 0 Then n = n + 1
     r = 0
 Next i
With Cells(1, 7)
 .CurrentRegion.ClearContents
 .Resize(st+1, 4) = sn
End With
End Sub
 
Laatst bewerkt:
Of

Code: 
Sub jec()
 Dim ar, sp, j As Long, jj As Long
 ar = Cells(1).CurrentRegion
 
 With CreateObject("scripting.dictionary")
   For j = 1 To UBound(ar)
     sp = Split(ar(j, 4), ", ")
     For jj = 0 To UBound(sp)
       .Item(.Count) = Array(ar(j, 1), ar(j, 2), ar(j, 3), sp(jj))
     Next
   Next
   Cells(1, 7).Resize(.Count, 4) = Application.Index(.items, 0, 0)
 End With
End Sub
 
@peter59, bij een derde artikel gaat het niet goed in je Query ;)
Table.SplitColumn werkt niet dynamisch bij standaard gebruik

PHP: 
let
    Source = Excel.CurrentWorkbook(){[Name="Tabel1"]}[Content],
    spCol = Table.AddColumn(Source, "Artikelnr", each Text.Split([Artikel nummer],", ")),
    result = Table.RemoveColumns(Table.ExpandListColumn(spCol, "Artikelnr"),{"Artikel nummer"})
in
    result
 
(vooral ;)) @HSV & @JEC,

Als we dan toch bezig blijven...
Laat me even verduidelijken: voor mezelf elimineer ik waar mogelijk ook altijd interactie met het werkblad, op mijn werk overigens ook (daar heeft namelijk niemand ook maar enige ambitie om iets te begrijpen van wat ik hen voorschotel), maar wie hier vragen komt stellen heeft, althans in vele gevallen, niet de kennis om met dit soort snellere code zelf aan de slag te gaan.
Ik merk ook vaak dat vraagstellers niet enkel een werkende oplossing zoeken, maar zelf op hun eigen tempo iets willen bijleren, vandaar mijn hier eerder geposte 'eenvoudige' code.
Nog vóór ik die hier neerzette had ik al, enkel voor mijn eigen lol, deze geschreven:
Code: 
Sub splitsen()

arr = Cells(1).CurrentRegion
With CreateObject("System.Collections.ArrayList")
  For i = 1 To UBound(arr)
    art = Split(arr(i, 4), ",")
    For ii = 0 To UBound(art)
      .Add Array(arr(i, 1), arr(i, 2), arr(i, 3), Trim(art(ii)))
    Next ii
  Next i
  res = Application.Transpose(Application.Transpose(.toarray))
  Cells(1, 6).Resize(UBound(res), 4) = res
End With

End Sub

Om maar te zeggen: natuurlijk zijn er bijna altijd meerdere wegen☺️
 
@Enigmasmurf ,

Ik heb ze allen hier wel eens getoond (dictionary, arraylist).
Ik heb hier kortgeleden van @jkp vernomen dat de dictionary er binnenkort uitgaat en niet meer zal werken en voor de arraylist heb je .NET FrameWork 3,5 nodig op je systeem.

Het voordeel van bovengenoemde methodes is dat de code korter wordt, maar kan het niet in snelheid op tegen #14.

Als je in jouw code van de Trim functie af wil kun je in de split de komma met een spatie schrijven.
Als je van de application.transpose(application.transpose( af wil zou ik het zo schrijven, wordt het nog iets sneller ook.
Code: 
Sub splitsen()
arr = Cells(1).CurrentRegion
With CreateObject("System.Collections.ArrayList")
  For i = 1 To UBound(arr)
    art = Split(arr(i, 4), ", ")
    For ii = 0 To UBound(art)
      .Add Array(arr(i, 1), arr(i, 2), arr(i, 3), art(ii))
    Next ii
  Next i
 Cells(1, 6).Resize(.Count, 4) = Application.Index(.toarray, 0)
End With
End Sub
 
@HSV

Hoewel ik je op je woord geloof toch even mezelf met een testje proberen geruststellen ;), en je methode doet het inderdaad in 0,16" t.o.v. 0,19" met de arraylist.
Application.Index is inderdaad handiger maar qua snelheid een nog kleinere winst.
En Trim had ik gebruikt met in het achterhoofd de mogelijkheid dat in een bestand met 17000 rijen de kans niet denkbeeldig is dat niet iedere komma door een spatie wordt gevolgd...

Het lijkt misschien niet meteen zo, maar zelf vind ik dat we het allemaal grotendeels eens zijn!
 
@HSV, dictionary zal (gelukkig) niet verdwijnen. Deze zit in een andere library(scripting runtime).

Met wat meer data zou ik transpose inderdaad vermijden in vba, kan meestal rond de 35K regels aan
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan