cijfers in kolom splitsen

Status
Niet open voor verdere reacties.
Sytse1

Sytse1

Gebruiker
Lid geworden
9 aug 2007
Berichten
584
Office versie
miDer
Bijgaand een werkblad met in een cel bijeengebrachte cijfers b.v. 1+2
Ik wil deze cijfers, zonder, het plusteken, afzonderlijk in een kolom plaatsen.
Dit lukt mij met de volgende code
Code: 
Sub schema()

    Range("E2").Select
    ActiveCell.FormulaR1C1 = "=LEFT(RC[-3],2)"
    Range("F2").Select
    ActiveCell.FormulaR1C1 = "=RIGHT(RC[-4],2)"
    
  '  Range("F2").Select
  '  ActiveCell.FormulaR1C1 = "=Mid(RC[-5],1)"
    
    Range("H2").Select
    ActiveCell.FormulaR1C1 = "tegen"
    Range("J2").Select
    ActiveCell.FormulaR1C1 = "=LEFT(RC[-6],2)"
    Range("K2").Select
    ActiveCell.FormulaR1C1 = "=RIGHT(RC[-7],2)"
    Range("E2:K2").Select
    Selection.AutoFill Destination:=Range("E2:K130"), Type:=xlFillDefault
    Range("E2:K130").Select
    ActiveWindow.SmallScroll Down:=-123
    Selection.Copy
    Range("M2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("M1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "speler1"
    Range("N1").Select
    ActiveCell.FormulaR1C1 = "speler2"
    Range("O1").Select
    ActiveCell.FormulaR1C1 = "speler3"
    Range("P1").Select
    ActiveCell.FormulaR1C1 = "tegen"
    Range("Q1").Select
    ActiveCell.FormulaR1C1 = "tegenspeler1"
    Range("R1").Select
    ActiveCell.FormulaR1C1 = "tegenspeler2"
    Range("S1").Select
    ActiveCell.FormulaR1C1 = "tegenspeler3"
    Cells.Select
    Selection.ColumnWidth = 8.29
    Range("Q4").Select
    Columns("Q:Q").EntireColumn.AutoFit
    Columns("R:R").EntireColumn.AutoFit
    Range("R2:S142").Select
    ActiveWindow.ScrollRow = 101
    ActiveWindow.ScrollRow = 100
    ActiveWindow.ScrollRow = 99
    ActiveWindow.ScrollRow = 98
    ActiveWindow.ScrollRow = 97
    ActiveWindow.ScrollRow = 96
    ActiveWindow.ScrollRow = 95
    ActiveWindow.ScrollRow = 94
    ActiveWindow.ScrollRow = 93
    ActiveWindow.ScrollRow = 92
    ActiveWindow.ScrollRow = 91
    ActiveWindow.ScrollRow = 90
    ActiveWindow.ScrollRow = 89
    ActiveWindow.ScrollRow = 88
    ActiveWindow.ScrollRow = 87
    ActiveWindow.ScrollRow = 86
    ActiveWindow.ScrollRow = 85
    ActiveWindow.ScrollRow = 84
    ActiveWindow.ScrollRow = 83
    ActiveWindow.ScrollRow = 82
    ActiveWindow.ScrollRow = 81
    ActiveWindow.ScrollRow = 80
    ActiveWindow.ScrollRow = 79
    ActiveWindow.ScrollRow = 78
    ActiveWindow.ScrollRow = 77
    ActiveWindow.ScrollRow = 76
    ActiveWindow.ScrollRow = 75
    ActiveWindow.ScrollRow = 74
    ActiveWindow.ScrollRow = 73
    ActiveWindow.ScrollRow = 72
    ActiveWindow.ScrollRow = 71
    ActiveWindow.ScrollRow = 70
    ActiveWindow.ScrollRow = 69
    ActiveWindow.ScrollRow = 68
    ActiveWindow.ScrollRow = 67
    ActiveWindow.ScrollRow = 66
    ActiveWindow.ScrollRow = 65
    ActiveWindow.ScrollRow = 64
    ActiveWindow.ScrollRow = 63
    ActiveWindow.ScrollRow = 62
    ActiveWindow.ScrollRow = 61
    ActiveWindow.ScrollRow = 60
    ActiveWindow.ScrollRow = 59
    ActiveWindow.ScrollRow = 58
    ActiveWindow.ScrollRow = 57
    ActiveWindow.ScrollRow = 56
    ActiveWindow.ScrollRow = 55
    ActiveWindow.ScrollRow = 54
    ActiveWindow.ScrollRow = 53
    ActiveWindow.ScrollRow = 52
    ActiveWindow.ScrollRow = 51
    ActiveWindow.ScrollRow = 50
    ActiveWindow.ScrollRow = 49
    ActiveWindow.ScrollRow = 48
    ActiveWindow.ScrollRow = 47
    ActiveWindow.ScrollRow = 46
    ActiveWindow.ScrollRow = 45
    ActiveWindow.ScrollRow = 44
    ActiveWindow.ScrollRow = 43
    ActiveWindow.ScrollRow = 42
    ActiveWindow.ScrollRow = 41
    ActiveWindow.ScrollRow = 40
    ActiveWindow.ScrollRow = 39
    ActiveWindow.ScrollRow = 38
    ActiveWindow.ScrollRow = 37
    ActiveWindow.ScrollRow = 36
    ActiveWindow.ScrollRow = 35
    ActiveWindow.ScrollRow = 34
    ActiveWindow.ScrollRow = 33
    ActiveWindow.ScrollRow = 32
    ActiveWindow.ScrollRow = 31
    ActiveWindow.ScrollRow = 30
    ActiveWindow.ScrollRow = 29
    ActiveWindow.ScrollRow = 28
    ActiveWindow.ScrollRow = 27
    ActiveWindow.ScrollRow = 26
    ActiveWindow.ScrollRow = 25
    ActiveWindow.ScrollRow = 24
    ActiveWindow.ScrollRow = 23
    ActiveWindow.ScrollRow = 22
    ActiveWindow.ScrollRow = 21
    ActiveWindow.ScrollRow = 20
    ActiveWindow.ScrollRow = 19
    ActiveWindow.ScrollRow = 18
    ActiveWindow.ScrollRow = 17
    ActiveWindow.ScrollRow = 16
    ActiveWindow.ScrollRow = 15
    ActiveWindow.ScrollRow = 14
    ActiveWindow.ScrollRow = 13
    ActiveWindow.ScrollRow = 12
    ActiveWindow.ScrollRow = 11
    ActiveWindow.ScrollRow = 10
    ActiveWindow.ScrollRow = 9
    ActiveWindow.ScrollRow = 8
    ActiveWindow.ScrollRow = 7
    ActiveWindow.ScrollRow = 6
    ActiveWindow.ScrollRow = 5
    ActiveWindow.ScrollRow = 4
    ActiveWindow.ScrollRow = 3
    ActiveWindow.ScrollRow = 2
    ActiveWindow.ScrollRow = 1
    Selection.Cut Destination:=Range("Q2:R142")
    Range("M2:S130").Select
    Selection.Replace What:="+", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    ActiveWindow.SmallScroll Down:=-150
    Range("N2").Select
    Columns("A:L").Select
    Range("L1").Activate
    Selection.Delete Shift:=xlToLeft
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Ronde"
    Range("A2").Select
    ActiveWindow.SmallScroll Down:=108
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("A5").Select

Dim r As Range
   For Each r In ActiveSheet.UsedRange
       If IsNumeric(r.Value) Then r.Value = Val(r.Value)
       If r < 1 Then r = " "
   Next r
   
 With Sheets(1)
    For Each cl In .UsedRange
        cl.Value = Trim(cl.Value)
    Next cl
    For Each cl In .Range("A3:A" & .Cells(Rows.Count, 2).End(xlUp).Row)
        If Not cl.Offset(, 1) = "" Then cl.Value = cl.Offset(-1).Value Else cl.Value = cl.Offset(-2).Value + 1
    Next cl
    .Columns(2).SpecialCells(4).EntireRow.Delete
End With
End Sub
Het gaat alleen op als er maar 2 cijfers in de cel staan.
Zodra er drie cijfers in staan wil in Mid gebruiken. Maar ik stuit dan steeds op een foutmelding.
Verder verdwijnt in voorbeeld in regel 21 op onverklaarbare wij het cijfer 42.
Iemand een idee waarom b.v. bij de eerste cel Mid niet werkt, maar left en right wel?
(Als Mid wel zou werken moet er eerst een controle zijn op het aantal + in de cel want dan weet je of er 3 cijfers in staan(dien dan uit elkaar gehaald moeten worden.)
b.v.d.
Sytse

Bekijk bijlage 90 spelers pers.toern.xls
 
Die cijfers met plus tekens kan je beter scheiden met de Split functie. Voorbeeldje voor de inhoud van cel D2:
Code: 
Sub test()
    Dim Cijfers() As String
    Dim i As Integer
    
    Cijfers = Split(Range("D2"), "+")
    
    For i = 0 To UBound(Cijfers)
        MsgBox Cijfers(i)
    Next i
End Sub

Zo kan je de volgende functie in een module maken:
Code: 
Function Cijfer(Waarde As String, Positie) As Integer
    Cijfer = Split(Waarde, "+")(Positie)
End Function

Aanroep in de betreffende cel: =Cijfer(D2;0)
Dit levert in de betreffende cel het getal 16 op.
=Cijfer(D2;1) levert dan 17 op.
=Cijfer(D2;2) levert dan 18 op.

Daarnaast zou ik de hele code die je plaatste anders schrijven, maar dat is een ander verhaal ;)
 
edmoor zei:
Daarnaast zou ik de hele code die je plaatste anders schrijven, maar dat is een ander verhaal ;)
Klik om te vergroten...
Ed heeft uiteraard wel gelijk. Simpel voorbeeldje uit je code:
Code: 
    ActiveWindow.ScrollRow = 101
    ActiveWindow.ScrollRow = 100
    ActiveWindow.ScrollRow = 99
    ActiveWindow.ScrollRow = 98
    ActiveWindow.ScrollRow = 97
    ActiveWindow.ScrollRow = 96
....
    ActiveWindow.ScrollRow = 3
    ActiveWindow.ScrollRow = 2
    ActiveWindow.ScrollRow = 1
Doet natuurlijk geen zier, die 101 regels. Alleen de laatste is effectief gebruikt, de eerste 100 regels (ik laat ze uiteraard niet allemaal zien) kun je net zo goed weglaten. En als je er toch 101 nodig hebt (je spaart toch geen dalmatiërs?) dan kan dat ook met een simpele lus:

Code: 
For i = 101 To 1 Step -1
    ActiveWindow.ScrollRow = i
Next i

Blijft wel de vraag staan: waarom??
 
Mijn antwoord op de vraag "waarom" kan ik alleen maar beantwoorden met "onkunde"
Bedankt voor de antwoorden.
Ik ga er mee aan de slag.
Als ik er uit ben zal ik de code plaatsen en de vraag afsluiten.
Nogmaals bedankt voor jullie reactie en code.
Sytse
 
Code iets vereenvoudigd.

Code: 
Sub hsv()
Dim cl As Range, sq
Application.ScreenUpdating = False
 With Blad1
      .Columns(1).SpecialCells(4) = "=r[-1]c"
      .Columns(3).SpecialCells(2) = "+tegen+"
    For Each cl In .Columns(2).SpecialCells(2)
        cl.Offset(, 3) = Replace(Replace(cl.Offset(, -1), "ronde ", ""), ":", "")
        sq = Split(Join(Application.Index(cl.Resize(, 3).Value, 1, 0)), "+")
            If UBound(sq) = 4 Then
                cl.Offset(, 4).Resize(, 2) = Array(sq(0), sq(1))
                cl.Offset(, 7) = sq(2)
                cl.Offset(, 8).Resize(, 2) = Array(sq(3), sq(4))
              Else
                cl.Offset(, 4).Resize(, 7) = sq
                cl.Offset(, 4).Resize(, 7) = cl.Offset(, 4).Resize(, 7).Value
            End If
        Next cl
      .Columns("a:d").Delete
      .Columns(1).SpecialCells(4).EntireRow.Delete
      .Columns.AutoFit
 End With
End Sub
 

Bijlagen

Code iets vereenvoudigd:

Code: 
Sub M_snb()
   sn = [if(B2:B200="","",B2:B200 & "+" & if(len(B2:B200)-len(substitute(B2:B200,"+",""))<>2,"+","")& C2:C200 & "+" & D2:D200)]
   
   For j = 1 To UBound(sn)
      If sn(j, 1) <> "" Then Cells(j + 1, 6).Resize(, UBound(Split(sn(j, 1), "+")) + 1) = Split(sn(j, 1), "+")
   Next
End Sub
 
@snb,
Jammer dat je het niet compleet maakt, de hoofdlijnen staan erop en dat stuk code is zeker vereenvoudigd. :thumb:
 
Leek me zo evident:

Code: 
Sub M_snb()
   sn = [if(B2:B200="","","+" & B2:B200 & "+" & if(len(B2:B200)-len(substitute(B2:B200,"+",""))<>2,"+","")& C2:C200 & "+" & D2:D200)]
   
   y = 1
   For j = 1 To UBound(sn)
      If sn(j, 1) <> "" Then Cells(j + 1, 5).Resize(, UBound(Split(sn(j, 1), "+")) + 1) = Split("Ronde " & y & sn(j, 1), "+")
      y = y - (sn(j, 1) = "")
   Next
End Sub
 
GEWELDIG(ik heb een hekel aan het woord super) bedankt.:thumb:
De code werkt als een sneltreinvaart.
Na lezing snap ik het wel, maar ik zou het niet zelf kunnen produceren.
Ik heb voor het verplaatsen en tekstinvulling er wat code bijgezet.
Tevens de code voor het numeriek maken.
Om het af te sluiten het te bewerken werkblad en de code.
Wellicht kunnen vragenstellers hier ook nog wat van leren.
Groet,
Sytse
Code: 
Sub M_snb()
'cijfers uit elkaar halen en afzonderlijk in een cel plaatsen
   sn = [if(B2:B200="","","+" & B2:B200 & "+" & if(len(B2:B200)-len(substitute(B2:B200,"+",""))<>2,"+","")& C2:C200 & "+" & D2:D200)]
   y = 1
   For j = 1 To UBound(sn)
      If sn(j, 1) <> "" Then Cells(j + 1, 5).Resize(, UBound(Split(sn(j, 1), "+")) + 1) = Split("" & y & sn(j, 1), "+")
      y = y - (sn(j, 1) = "")
   Next
 
 'kolommen verwijderen en kolommen verplaatsen
   Columns("A:D").Select
    Selection.Delete Shift:=xlToLeft
    Range("B1:I1").Select
    Selection.Cut Destination:=Range("A1:H1")
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select

'Tekst in kopregel
    ActiveWindow.SmallScroll Down:=-3
    Rows("1:1").RowHeight = 13.5
    Rows("1:1").Select
    Selection.ClearContents
    Range("A1").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Ronde"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "speler1"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "spelers"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "speler3"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "tegen"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "tegenspeler1"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "tegenspeler2"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "tegenspeler3"
    Range("I1").Select
 'cellen mummeriek maken en lege regels verwijderen
   With Sheets(1)
    For Each cl In .UsedRange
        cl.Value = Trim(cl.Value)
    Next cl
    For Each cl In .Range("A3:A" & .Cells(Rows.Count, 2).End(xlUp).Row)
        If Not cl.Offset(, 1) = "" Then cl.Value = cl.Offset(-1).Value Else cl.Value = cl.Offset(-2).Value + 1
    Next cl
    .Columns(2).SpecialCells(4).EntireRow.Delete
End With
End Sub
Bekijk bijlage test 35 spelers pers.toern.xls
 
Kolommen verwijderen doe je zo:

Code: 
columns(1).resize(,4).delete

De overige code lijkt me overbodig.
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan