vba splitsen van cel waardes meenemen

Status
Niet open voor verdere reacties.
T

Tweety1

Gebruiker
Lid geworden
6 mrt 2013
Berichten
637
Ik ben opzoek naar 2 verschillende vba's die cel splits op basis van "/"

VBA 1 (voorbeeld 1)
Kolom H ieder stukje splitsen in aparte cellen onder elkaar en de gegevens meenemen van de ander cellen. Sheet kan meerdere kolommen bevatten.


VBA 2 (voorbeeld 2)
Kolom H en I splitsen maar de gegevens van de overige cellen niet meenemen.

Voorbeeld
Bekijk bijlage Splitsen.xlsx

mvg
Kasper
 
Laatst bewerkt:
Laat de code maar eens lopen (voor blad uitkomst voorbeeld 1.
Code: 
Sub hsv()
Dim sn, sq, i As Long, j As Long, n As Long
sn = Sheets("voorbeeld 1").Cells(1).CurrentRegion
ReDim arr(12, 0)
For i = 1 To UBound(sn)
  sq = Split(sn(i, 8), "/")
    For j = 0 To UBound(sq)
            arr(0, n) = sn(i, 1)
            arr(1, n) = sn(i, 2)
            arr(2, n) = sn(i, 3)
            arr(3, n) = sn(i, 4)
            arr(4, n) = sn(i, 5)
            arr(5, n) = sn(i, 6)
            arr(6, n) = sn(i, 7)
            arr(7, n) = sq(j)
            arr(8, n) = sn(i, 9)
            arr(9, n) = sn(i, 10)
            arr(10, n) = sn(i, 11)
            arr(11, n) = sn(i, 12)
            arr(12, n) = sn(i, 13)
            n = n + 1
      ReDim Preserve arr(12, n)
    Next j
  Next i
    With Sheets("uitkomst voorbeeld 1")
     .Cells(1).CurrentRegion.Offset(1).ClearContents
     .Cells(1).Resize(UBound(arr, 2), UBound(sn, 2)) = Application.Transpose(arr)
    End With
End Sub
 
of

Code: 
Sub M_snb()
   sn = Sheet1.Cells(1).CurrentRegion
   
   With CreateObject("scripting.dictionary")
      For j = 2 To UBound(sn)
        sp = Application.Index(sn, j)
        st = Split(sn(j, 8), "/")
        For jj = 0 To UBound(st)
          sp(8) = st(jj)
          .Item("P_" & .Count) = sp
        Next
      Next
      
      Sheet1.Cells(20, 1).Resize(.Count, UBound(sn, 2)) = Application.Index(.items, 0, 0)
   End With
End Sub
 
Heb de laatse vba code gebruikt en klein beetje aangepast

Code: 
Sub M_snb()
   sn = ActiveSheet.Cells(1).CurrentRegion
   
   With CreateObject("scripting.dictionary")
      For j = 2 To UBound(sn)
        sp = Application.Index(sn, j)
        st = Split(sn(j, 8), "/")
        For jj = 0 To UBound(st)
          sp(8) = st(jj)
          .Item("P_" & .Count) = sp
        Next
      Next
      
      ActiveSheet.Cells(2, 1).Resize(.Count, UBound(sn, 2)) = Application.Index(.items, 0, 0)
   End With
End Sub

Nu alleen nog de 2e vraag
 
Hij is mooi @snb.
Qua snelheid maak het niet uit (moet nog zien over een x factor aan rijen of de index-constructie het aan kan), maar hij is mooi.

@Tweety,

Kijk een naar dit stukje code.

Code: 
  st = Split(sn(j, 8), "/") 'hier wordt kolom 8 gesplitst.
       For jj = 0 To UBound(st)
          sp(8) = st(jj)              'hier wordt kolom 8 in de nieuwe reeks het gesplitst gedeelte.
          .Item("P_" & .Count) = sp
        Next

Wat zou er dan aan toegevoegd moeten worden denk je?
 
Wat ik nu heb toegevoegd aan de vba werkt goed alleen had ik in het voorbeeld aangeven dat cellen aangevuld dienen te worden. Dit moest eigenlijk niet gebeuren.
Hier bij een nieuwe voorbeeld bestand.

Bekijk bijlage Splitsenv2.xlsm

Code: 
Sub M_snb()
   sn = ActiveSheet.Cells(1).CurrentRegion
   
   With CreateObject("scripting.dictionary")
      For j = 2 To UBound(sn)
        sp = Application.Index(sn, j)
        st = Split(sn(j, 8), "/")
        st1 = Split(sn(j, 9), "/")
        For jj = 0 To UBound(st)
          sp(8) = st(jj)
          sp(9) = st1(jj)
          .Item("P_" & .Count) = sp
        Next
       Next
      ActiveSheet.Cells(2, 1).Resize(.Count, UBound(sn, 2)) = Application.Index(.items, 0, 0)
   End With
End Sub
 
Voeg het blauwe gedeelte toe.
Code: 
For jj = 0 To UBound(st)
          sp(8) = st(jj)
          sp(9) = st1(jj)
          .Item("P_" & .Count) = sp
[COLOR=#0000ff]          For jjj = 1 To UBound(sp)-1[/COLOR]
[COLOR=#0000ff]            Select Case jjj[/COLOR]
[COLOR=#0000ff]              Case 1 To 7, 10 To UBound(sp)-1[/COLOR]
[COLOR=#0000ff]               sp(jjj) = ""[/COLOR]
[COLOR=#0000ff]             End Select[/COLOR]
[COLOR=#0000ff]          Next jjj[/COLOR]
        Next jj
 
Dit moet je niet willen, want met de huidige code creëer je een genormaliseerde tabel die een uitstekende basis is voor filters en draaitabellen.

Als je wil volharden in het onverstandige:

Code: 
Sub M_snb()
   With Blad1.Cells(1).CurrentRegion
     sn = .Resize(.Rows.Count + 1)
   End With
   
   With CreateObject("scripting.dictionary")
      For j = 2 To UBound(sn)
        sp = Application.Index(sn, j)
        st = Split(sn(j, 8), "/")
        sq = Split(sn(j, 9), "/")
        For jj = 0 To UBound(st)
          If jj > 0 Then sp = Application.Index(sn, UBound(sn))
          sp(8) = st(jj)
          sp(9) = sq(jj)
          .Item("P_" & .Count) = sp
        Next
       Next
      
      Blad2.Cells(30, 1).Resize(.Count, UBound(sn, 2)) = Application.Index(.items, 0, 0)
   End With
End Sub

of

Code: 
Sub M_snb()
   With Blad1.Cells(1).CurrentRegion
     sn = .Resize(.Rows.Count + 1)
   End With
   
   With CreateObject("scripting.dictionary")
      For j = 2 To UBound(sn)
        sp = Application.Index(sn, j)
        st = Split(sn(j, 8) & "/" & sn(j, 9), "/")
        For jj = 0 To UBound(st) \ 2
          If jj > 0 Then sp = Application.Index(sn, UBound(sn))
          sp(8) = st(jj)
          sp(9) = st(jj + (UBound(st) + 1) \ 2)
          .Item("P_" & .Count) = sp
        Next
       Next
      
      Blad2.Cells(30, 1).Resize(.Count, UBound(sn, 2)) = Application.Index(.items, 0, 0)
   End With
End Sub
 
Laatst bewerkt:
Ik snap het dat het niet handig is om de cellen niet mee te kopiëren.
Alleen voor het inlezen van script dien je het zo aan te leveren.
Waar ik trouwens niet rekening mee heb gehouden is dat een van de kolommen langer kan zijn dan de ander (meerdere "/")
 
Bij het draaien van de macro met een groter bestand krijg ik de foutcode 13 bij de regel "Application.Index" (dat gaf je al eerder aan of de index-constructie het aan kon).
De eerst macro werkt wel goed alleen weet ik niet hoe die kan aanpassen
 
Wat je zelf niet kunt, kun je het beste uitbesteden.
 
Laatst bewerkt:
Heb wel voor elkaar gekregen in de macro van hsv dat kolom 9 wordt gesplit. Dit gaat alleen goed als de kolommen precies de zelfde aantal "/" heeft. Dit wil graag veranderen in variable.
Heb ook geprobeerd de vba aan te passen zodat de tekst niet wordt mee gekopieerd. alleen kom ik daar niet uit.

Code: 
Sub hsv()
Dim sn, sq, i As Long, j As Long, n As Long
sn = Sheets("voorbeeld 2").Cells(1).CurrentRegion
ReDim arr(14, 0)
For i = 1 To UBound(sn)
  sq = Split(sn(i, 8), "/")
    sq1 = Split(sn(i, 9), "/")
    For j = 0 To UBound(sq)
            arr(0, n) = sn(i, 1)
            arr(1, n) = sn(i, 2)
            arr(2, n) = sn(i, 3)
            arr(3, n) = sn(i, 4)
            arr(4, n) = sn(i, 5)
            arr(5, n) = sn(i, 6)
            arr(6, n) = sn(i, 7)
            arr(7, n) = sq(j)
            arr(8, n) = sq1(j)
            arr(9, n) = sn(i, 10)
            arr(10, n) = sn(i, 11)
            arr(11, n) = sn(i, 12)
            arr(12, n) = sn(i, 13)
            arr(13, n) = sn(i, 14)
            n = n + 1
      ReDim Preserve arr(14, n)
    Next j
  Next i
    With Sheets("voorbeeld 2")
     .Cells(1).CurrentRegion.Offset(1).ClearContents
     .Cells(1).Resize(UBound(arr, 2), UBound(sn, 2)) = Application.Transpose(arr)
    End With
End Sub
 
Test het eens.
Code: 
Sub hsv()
Dim sn, sq, sq1, i As Long, j As Long, jj As Long, n As Long, langste As Long
sn = Sheets("voorbeeld 2").Cells(1).CurrentRegion
ReDim arr(14, 0)
For i = 1 To UBound(sn)
  sq = Split(sn(i, 8), "/")
    sq1 = Split(sn(i, 9), "/")
 langste = IIf(UBound(sq) > UBound(sq1), UBound(sq), UBound(sq1))
    For j = 0 To langste
      If j < 1 Then
            For jj = 1 To 14
              Select Case jj
                  Case jj = 1 To 7, 10 To 14
                     arr(jj - 1, n) = sn(i, jj)
                  Case jj = 8 To 9
                     If j <= UBound(sq) Then arr(7, n) = sq(j)
                     If j <= UBound(sq1) Then arr(8, n) = sq1(j)
               End Select
             Next jj
          Else
              If j <= UBound(sq) Then arr(7, n) = sq(j)
              If j <= UBound(sq1) Then arr(8, n) = sq1(j)
          End If
        n = n + 1
      ReDim Preserve arr(14, n)
    Next j
  Next i
    With Sheets("uitkomst voorbeeld 2")
     .Cells(1).CurrentRegion.Offset(1).ClearContents
     .Cells(1).Resize(UBound(arr, 2), UBound(sn, 2)) = Application.Transpose(arr)
    End With
End Sub
 
Ziet er goed uit. Kom nog 1 klein foutje tegen die zowel bij bovenstaande als bij de eerste vba ontbreekt.
Indien de cel in kolom H en I leeg is dan wordt nu de rij verwijderd. Deze wil ik laten staan.

Voorbeeld:
Bekijk bijlage Splitsenv3.xlsm
 
Verander...
Code: 
For j = 0 To langste
...in.
Code: 
For j = 0 To IIf(langste > -1, langste, 0)
 
En welke aanpassing dien ik in de eerste vba (voorbeeld 1) te doen?
En is ook mogelijk om de text die wordt gesplitst te sorteren op alfabet?
Zowel bij voorbeeld 1 en 2
 
Laatst bewerkt:
Ik heb wel een vba gevonden die de cel sorteert. Deze kan ik eerst laaten draaien voordat ik ga splitsen.

Code: 
Sub SortValuesInCell()
Dim rng As Range
Dim cell As Range
Dim del As String
Dim Arr As Variant

On Error Resume Next
Set rng = Range("H2:I" & Range("B" & Rows.Count).End(xlUp).Row)
del = "/"
On Error GoTo 0

For Each cell In rng
    Arr = Split(cell, del)
    SelectionSort Arr
    cell = Join(Arr, del)
Next cell

End Sub

Function SelectionSort(TempArray As Variant)
    Dim MaxVal As Variant
    Dim MaxIndex As Integer
    Dim i As Integer, j As Integer

    ' Step through the elements in the array starting with the
    ' last element in the array.
    For i = UBound(TempArray) To 0 Step -1

        ' Set MaxVal to the element in the array and save the
        ' index of this element as MaxIndex.
        MaxVal = TempArray(i)
        MaxIndex = i

        ' Loop through the remaining elements to see if any is
        ' larger than MaxVal. If it is then set this element
        ' to be the new MaxVal.
        For j = 0 To i
            If TempArray(j) > MaxVal Then
                MaxVal = TempArray(j)
                MaxIndex = j
            End If
        Next j

        ' If the index of the largest element is not i, then
        ' exchange this element with element i.
        If MaxIndex < i Then
            TempArray(MaxIndex) = TempArray(i)
            TempArray(i) = MaxVal
        End If
    Next i

End Function
 
Laatst bewerkt:
zoiets?
Code: 
Sub hsv()
Dim sn, sq, sq1, i As Long, j As Long, jj As Long, n As Long, langste As Long
sn = Sheets("voorbeeld 1").Cells(1).CurrentRegion
ReDim arr(14, 0)
For i = 1 To UBound(sn)
  sq = Split(sn(i, 8), "/")
    sq1 = Split(sn(i, 9), "/")
 langste = IIf(UBound(sq) > UBound(sq1), UBound(sq), UBound(sq1))
      For j = 0 To IIf(langste > -1, langste, 0)
            For jj = 1 To UBound(sn, 2)
             Select Case jj
              Case jj = 1 To 7, 10 To UBound(sn, 2)
                  arr(jj - 1, n) = sn(i, jj)
              Case jj = 8 To 9
                  If j <= UBound(sq) Then arr(7, n) = sq(j)
                  If j <= UBound(sq1) Then arr(8, n) = sq1(j)
               End Select
             Next jj
        n = n + 1
      ReDim Preserve arr(14, n)
    Next j
  Next i
    With Sheets("uitkomst voorbeeld 1")
     .Cells(1).CurrentRegion.Offset(1).ClearContents
     .Cells(1).Resize(UBound(arr, 2), UBound(sn, 2)) = Application.Transpose(arr)
    End With
End Sub
 
Ik bedoelde eigenlijk onderstaande vba.
Is de cel in h leeg dan niet de rij verwijderen.

Code: 
Sub hsv()
Dim sn, sq, i As Long, j As Long, n As Long
sn = Sheets("voorbeeld 1").Cells(1).CurrentRegion
ReDim arr(12, 0)
For i = 1 To UBound(sn)
  sq = Split(sn(i, 8), "/")
    For j = 0 To UBound(sq)
            arr(0, n) = sn(i, 1)
            arr(1, n) = sn(i, 2)
            arr(2, n) = sn(i, 3)
            arr(3, n) = sn(i, 4)
            arr(4, n) = sn(i, 5)
            arr(5, n) = sn(i, 6)
            arr(6, n) = sn(i, 7)
            arr(7, n) = sq(j)
            arr(8, n) = sn(i, 9)
            arr(9, n) = sn(i, 10)
            arr(10, n) = sn(i, 11)
            arr(11, n) = sn(i, 12)
            arr(12, n) = sn(i, 13)
            n = n + 1
      ReDim Preserve arr(12, n)
    Next j
  Next i
    With Sheets("uitkomst voorbeeld 1")
     .Cells(1).CurrentRegion.Offset(1).ClearContents
     .Cells(1).Resize(UBound(arr, 2), UBound(sn, 2)) = Application.Transpose(arr)
    End With
End Sub
 
Wordt het verwijderd bij jou?
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan