Teks naar colommen

[kaan]

Tekst naar colommen

Beste,

Het wil me niet lukken om deze macro werkend te krijgen, wie kan mijn hier bij helpen?

Alvast bedankt....

Sub Text_to_Columns()
Dim i As Integer, j As Integer

Dim s As String

j = 6
i = 6
Do While Worksheets(2).Cells(i, 1) <> " "

If Worksheets(2).Cells(i, 3) <> " " Then
j = j + 1
End If
i = i + 1
Loop
'MsgBox "i=" & i

s = "A" & j
'MsgBox "s=" & s

Selection.TextToColumns Destination:=Range(s), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(5, 1), Array(11, 1), Array(19, 1), Array(28, 1), _
Array(35, 1), Array(42, 1), Array(46, 1), Array(52, 1), Array(59, 1))

End Sub

 

[dropl]

Het zou duidelijker zijn als je erbij vertelde wat dit zou moeten doen...mij is het iig niet duidelijk

 

[Wigi]

Hello

Sub Text_to_Columns()
    Dim rngTxtToCols As Range
    Application.DisplayAlerts = False
    Set rngTxtToCols = Range("A12:A" & Range("A" & Rows.Count).End(xlUp).Row)
    rngTxtToCols.TextToColumns Destination:=rngTxtToCols.Range("A1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(5, 1), Array(11, 1), Array(14, 1), Array(19, 1), _
        Array(25, 1), Array(37, 1), Array(42, 1), Array(46, 1), Array(52, 1), Array(59, 1))
    Application.DisplayAlerts = True
End Sub

Wigi

 

[Wigi]

Bedankt om code tags te gebruiken, ik wilde het net vragen

Maak wel geen schrijffouten in de topic titel, anders loopt de zoekfunctie in het honderd.

 

[kaan]

WIGI bedankt,

colommen ik zag dit later pas maar kan het niet meer aanpassen helaas.

 

[Wigi]

ook

teks...

 

[Wigi]

WIGI bedankt

graag gedaan.

 

[kaan]

WIGI,

Tekst toe kolommen werkt nu met jou code maar als ik nieuwe data toevoeg en doe op nieuw tekst toe klom gaat hij oude tekst verwijderen alleen regel A blijft nog over.

Hoe kan ik dat voorkomen?

 

[Wigi]

alleen regel A

Kolom A, niet?

 

[kaan]

Nee, vreemd genoeg niet kun je even kijken naar bijlage?
Heb een voorbeeld toegevoegd.

 

[Wigi]

Sub Text_to_Columns()
    Dim rngTxtToCols As Range, lFirstRow As Long
    Application.DisplayAlerts = False
    
    lFirstRow = IIf(Range("B" & Rows.Count).End(xlUp).Row = 11, 12, Range("B" & Rows.Count).End(xlUp).Row + 1)
    
    Set rngTxtToCols = Range("A" & lFirstRow & ":A" & Range("A" & Rows.Count).End(xlUp).Row)
    rngTxtToCols.TextToColumns Destination:=rngTxtToCols.Range("A1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(5, 1), Array(11, 1), Array(14, 1), Array(19, 1), _
        Array(25, 1), Array(37, 1), Array(42, 1), Array(46, 1), Array(52, 1), Array(59, 1))
    Application.DisplayAlerts = True
End Sub

Deze code werkt als je nieuwe regels telkens vanonder bijgezet worden.

En nu ga ik pitten, slaapwel.

Wigi

 

[kaan]

Welterusten

Voor anderen die nog wakker zijn?

Ik porbeen onderstaande code toe te passen maar het werkt niet helemaal waar maak ik fout?

Sub maaktijd()

Dim Tijd As String, Tijd2 As String, Tijd3 As String
Dim i As Integer, Aantal As Integer
Dim j As Integer, k As Integer
Dim MaxRegelsPag As Integer
Dim NewTime As Long
Dim a As String, b As String, c As String, Rij As String


MaxRegelsPag = 75

' Remove uca

j = 0
i = 12
Do While (Cells(i, 2) <> " " And Cells(i, 3) <> " ")
c = Left(Cells(i, 3), 2)
' MsgBox c & i
If ((c <> "LO") And (c <> "NI") And (c <> "FB") And (c <> "U8") _
And (c <> "FI") And (c <> "KC") And (c <> "AH") And (c <> "KM")) Then
Rij = i & ":" & i
Rows(Rij).Select
Selection.Delete Shift:=xlUp
i = i - 1
j = j + 1
End If

c = Cells(i, 7)
If (c = "PP") Then
Rij = i & ":" & i
Rows(Rij).Select
Selection.Delete Shift:=xlUp
i = i - 1
j = j + 1
End If

i = i + 1
' MsgBox i
Loop

'secure the next two lines
For k = i To i + 2
Cells(k, 2) = " "
' MsgBox "k=" & k
Next k


' Time handling
For j = 1 To 3
If j = 1 Then k = 2
If j = 2 Then k = 8
If j = 3 Then k = 9

For i = 12 To MaxRegelsPag
'Eba time reading
Tijd = Worksheets(2).Cells(i, k)
Aantal = Len(Tijd)
If (Right(Tijd, 1) = "A") And (Aantal = 5) Then
' ivm nul voor de tijd (overgang datum)
Worksheets(2).Cells(i, k).NumberFormat = "h:mm;@"
a = Left(Tijd, 2): b = Left(Right(Tijd, 3), 2)
c = a & ":" & b
Worksheets(2).Cells(i, k) = c
Else
' In case of 4 characters
If (Right(Tijd, 1) = "A") Then
Worksheets(2).Cells(i, k).NumberFormat = "h:mm;@"
a = Left(Tijd, 1): b = Left(Right(Tijd, 3), 2)
c = a & ":" & b
Worksheets(2).Cells(i, k) = c
End If
End If
Next i
Next j

'Correction first column with scheduletimes
For i = 12 To MaxRegelsPag
Tijd = Worksheets(2).Cells(i, 1)
a = Right(Tijd, 4)
Worksheets(2).Cells(i, 1) = a
Next i

End Sub

 

[Wigi]

Geef eens wat meer uitleg, zo voor mijn plezier op een zaterdag bladzijden code doorlezen is ook niet alles hoor...

 

[kaan]

Goedemorgen,

Fijn dat jij er weer bent.

Ik heb een file die oud is geschreven is door iemand anders, nu probeer ik het zelf ook te begrijpen

Volgende ben ik aan het proberen, als eerste kolom B, I, J, zijn tijden dat probeer ik nu om te zetten naar tijd. Dus zoals deze 1236A omzetten naar 12:36

Daarna moet gekeken worden of er een regel moet worden verwijderd als zo als hier onder

Do While (Cells(i, 2) <> " " And Cells(i, 3) <> " ")

als deze niet onder aan deze overheen komt moet de hele regel worden verwijderd.

If ((c <> "HV") And (c <> "LO") And (c <> "NI") And (c <> "FB") And (c <> "U8") _
And (c <> "FI") And (c <> "KC") And (c <> "AH") And (c <> "KM")) Then

dit is een gedeeldte er van..