Tekst naar kolommen

Status
Niet open voor verdere reacties.
T

Tweety1

Gebruiker
Lid geworden
6 mrt 2013
Berichten
637
Onderstaande macro zou ik graag willen aanpassen zodat de eerste kolom een datumopmaak heeft.

Code: 
Sub sg()
Dim myArrB() As Variant              ' Array to be used for FieldInfo
Dim iItem As Long                    ' Counter for Fields in FieldInfo
Dim myArrayTemp() As Variant         ' Temporary Array used for Arrays inside of FieldInfo Array
Dim myFields As Long                 ' Variable to hold number of fields we want to setup

myFields = 20                       ' Number of fields we want.

myFields = myFields - 1            ' Zero Based - This is for the array index.  subtract 1

' Create a Jagged Array that is required by TextToColumns
' -------------------------------------------------------
ReDim myArrB(0 To myFields)          ' Redimension the Array to the number of fields

For iItem = 0 To myFields            ' Loop through each field
    ReDim myArrayTemp(0 To 1)        ' Redimension the Array inside the FieldInfo Array
    myArrayTemp(0) = iItem + 1       ' iItem is the field number
    myArrayTemp(1) = 2               ' xlTextFormat DataType
    myArrB(iItem) = myArrayTemp      ' Build the FileInfo Array by storing the Array inside the Array
Next iItem
' -------------------------------------------------------


Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
        TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=True, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", FieldInfo:=myArrB, TrailingMinusNumbers:=True
End Sub

mvg
Kasper
 
Om een kolom op datum formaat te zetten is maar 1 regeltje nodig in plaats van wat je in #1 laat zien.
Plaats dus een voorbeeld document en laat daar in zien wat je bedoeling is.
 
Hierbij een voorbeeld bestand.

Op tabblad 2 een voorbeeld hoe het eruit moet zien.
 

Bijlagen

  • TextKolom.xlsx
    10,4 KB · Weergaven: 22
klassieke "gegevens > tekst naar kolommen", scheiden op ";", 1e veld is datumtype dmj en de rest standaard
 

Bijlagen

  • TextKolom.xlsx
    10,8 KB · Weergaven: 23
Ok. Kan dit ook geautomatiseerd worden via een VBA. ( de kolommen zijn namelijk niet altijd de zelfde aantallen).
Alleen de eerste kolom is een datum veld en de rest is tekst opmaak.
 
Laatst bewerkt:
Code: 
Sub ttc()
 Sheets("voorbeeld").Columns(1).TextToColumns Cells(1), 1, , , , True, , , , , Array(1, 4)
End Sub
 
@HSV. De tekst wordt wel goed gesplit en is het eerste kolom de opmaak als datum.
De rest van de kolommen staat nu de opmaak als standaard. Dit wil ik namelijk wijzigen in tekst.
Ik kolom "E" staat nu bv een "1" dit zou in de tekst opmaak "0001" zijn, zie tabblad "uitkomst".
Hoe kan ik dit eraan toevoegen?

Ik zag dat er nog een fout in de macro zat. Zie rood wat is veranderd.
Code: 
Sub sg()
Dim myArrB() As Variant              ' Array to be used for FieldInfo
Dim iItem As Long                    ' Counter for Fields in FieldInfo
Dim myArrayTemp() As Variant         ' Temporary Array used for Arrays inside of FieldInfo Array
Dim myFields As Long                 ' Variable to hold number of fields we want to setup

myFields = Len(Range("A1")) - Len(Application.WorksheetFunction.Substitute(Range("A1"), ";", "")) + 1                      ' Number of fields we want.

myFields = myFields - 1            ' Zero Based - This is for the array index.  subtract 1

' Create a Jagged Array that is required by TextToColumns
' -------------------------------------------------------
ReDim myArrB(0 To myFields)          ' Redimension the Array to the number of fields

For iItem = 0 To myFields            ' Loop through each field
    ReDim myArrayTemp(0 To 1)        ' Redimension the Array inside the FieldInfo Array
    myArrayTemp(0) = iItem + 1       ' iItem is the field number
    myArrayTemp(1) = 2               ' xlTextFormat DataType
    myArrB(iItem) = myArrayTemp      ' Build the FileInfo Array by storing the Array inside the Array
Next iItem
' -------------------------------------------------------


Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=[COLOR="#FF0000"]xlDelimited[/COLOR], _
        TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=True, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", FieldInfo:=myArrB, TrailingMinusNumbers:=True
End Sub
 
Laatst bewerkt:
Code: 
Sub ttc()
 Sheets("voorbeeld").Columns(1).TextToColumns Cells(1), 1, , , , True, , , , , Array(Array(1, 4), Array(2, 2), Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 2), _
        Array(7, 1), Array(8, 2), Array(9, 2), Array(10, 2), Array(11, 2), Array(12, 2), Array(13, 2), Array(14, 2), Array(15, 2))
End Sub
in jouw macro (niet getest, enkel door deductie).
"Item" is anders niet wenselijk om als variabele te gebruiken binnen VBA, dat is gereserveerd voor andere zaken.
Ik zou liever "it" zien. Ooit kom je daarmee nog in de problemen
Code: 
     myArrayTemp(1) = IIf(Item = 0, 4, 2)       ' de 1e datum, de rest xlTextFormat DataType

Voor de grap, de 2 gedachtengangen met elkaar gecombineerd
Code: 
Sub ttc()
   Dim arr()
   myFields = Len(Range("A1").Value) - Len(Replace(Range("A1").Value, ";", "")) + 1   ' Number of fields we want.

   ReDim arr(1 To 15, 1 To 2)
   For i = 1 To UBound(arr)
      arr(i, 1) = i: arr(i, 2) = IIf(i = 1, 4, 2)
   Next

   Sheets("voorbeeld").Columns(1).TextToColumns Cells(1), 1, , , , True, , , , , arr
End Sub
 
Laatst bewerkt:
Thanks "Cow18". Ik heb uiteindelijk de laatse vba gebruikt en "1 to 15" vervangen door "1 to myfields".
Is het trouwens ook mogelijk om alleen de eerste 2 kolom op te maken al datum veld?
Ik heb al iets geprobeerd (zie rood) alleen werkt dat niet.

Code: 
Sub ttc()
   Dim arr()
   myFields = Len(Range("A1").Value) - Len(Replace(Range("A1").Value, ";", "")) + 1   ' Number of fields we want.

   ReDim arr(1 To myFields, 1 To 2)
   For i = 1 To UBound(arr)
      arr(i, 1) = i: arr(i, 2) = IIf(i = 1, 4, 2) [COLOR="#FF0000"]Or IIf(i = 2, 4, 2)[/COLOR]
   Next

   Sheets("voorbeeld").Columns(1).TextToColumns Cells(1), 1, , , , True, , , , , arr
End Sub
 
Laatst bewerkt:
Code: 
Sub ttc()
Dim myFields As Long, i As Long
myFields = Len(Range("A1").Value) - Len(Replace(Range("A1").Value, ";", "")) + 1   ' Number of fields we want.
  ReDim arr(1 To myFields, 1 To 2)
   For i = 1 To UBound(arr)
      arr(i, 1) = i: arr(i, 2) = IIf(i [COLOR=#ff0000]<[/COLOR] [COLOR=#ff0000]3[/COLOR], 4, 2)
   Next
Sheets("voorbeeld").Columns(1).TextToColumns , 1, , , , True, , , , , arr
End Sub

Of:
Code: 
myFields = UBound(Split(Cells(1), ";")) + 1 ' Number of fields we want.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan