Sub MyArray_Work()

Dim TextToColumnsValues() As Variant, i As Integer, MyNum As Integer, NumRow As Integer

NumRow = Range("B" & Rows.Count).End(xlUp).Row


ReDim TextToColumnsValues(NumRow)

For i = 1 To NumRow

   MyNum = Range("B" & i).Value

   TextToColumnsValues(i) = Array(MyNum, 2)

Next

Debug.Print TextToColumnsValues(6)



Columns("C:C").Select

    Selection.TextToColumns Destination:=Range("C1"), DataType:=xlFixedWidth, _
        FieldInfo:=TextToColumnsValues, TrailingMinusNumbers:=True

CodePudding user response：

Apply TextToColumns Using Data From Column

• The Field argument requires a 1D array holding two-element 1D arrays, an array of arrays (jagged array).

Sub MyArray_Work()
    
    ' Define constants.
    
    Const sFirstCellAddress As String = "B2"
    Const dFirstCellAddress As String = "C2"
    Const ttcFormatNumber As Long = 2 ' Text or 1 - General, 4 - Date, 9 - Skip
    
    ' Reference the worksheet.
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    ' Reference the source range.
    
    Dim srg As Range
    Dim srCount As Long
    
    With ws.Range(sFirstCellAddress)
        Dim sLastRow As Long
        sLastRow = ws.Cells(ws.Rows.Count, .Column).End(xlUp).Row
        srCount = sLastRow - .Row   1
        If srCount < 1 Then Exit Sub
        Set srg = .Resize(srCount)
    End With

    ' Reference the destination range.
 
    Dim drg As Range
    
    With ws.Range(dFirstCellAddress)
        Dim dLastRow As Long
        dLastRow = ws.Cells(ws.Rows.Count, .Column).End(xlUp).Row
        Dim drCount As Long: drCount = dLastRow - .Row   1
        If drCount < 1 Then Exit Sub
        Set drg = .Resize(drCount)
    End With

    ' Write the values from the source range to the source array.
    
    Dim sData() As Variant
    
    If srCount = 1 Then ' one-cell
        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
    Else ' multiple cells
        sData = srg.Value
    End If

    ' Define the destination arrays.
    
    Dim ttcColumnData() As Variant: ReDim ttcColumnData(1 To srCount)
    Dim ttcSingleData() As Variant: ReDim ttcSingleData(1 To 2)
    ttcSingleData(2) = ttcFormatNumber
        
    ' Write the values from the source array
    ' to the destination array of arrays.
        
    Dim sr As Long
    
    For sr = 1 To srCount
        ttcSingleData(1) = sData(sr, 1)
        ttcColumnData(sr) = ttcSingleData ' array to element
    Next sr
 
    ' Use the destination array to apply 'TextToColumns'
    ' on the destination range. 
    
    drg.TextToColumns Destination:=drg, DataType:=xlFixedWidth, _
        FieldInfo:=ttcColumnData, TrailingMinusNumbers:=True

    ' Inform.

    MsgBox "Data parsed.", vbInformation

End Sub

The Dialog

• If there is already data in the columns next to the first column, a dialog with the following message will appear:

There's already data here. Do you want to replace it?

• If you select Yes, you will overwrite the data.
• But if you select Cancel, the following error will occur:

Run-time error '1004': Unable to get the TextToColumns property of the Range class.

• To overwrite without the dialog appearing, you could use the following:

  Application.DisplayAlerts = False
      drg.TextToColumns Destination:=drg, DataType:=xlFixedWidth, _
          FieldInfo:=ttcColumnData, TrailingMinusNumbers:=True
  Application.DisplayAlerts = True
  

• To let the dialog appear but avoid the error occurring, you could use something like this:

  Dim ttc As Variant:
  On Error Resume Next
      ttc = drg.TextToColumns( _
          Destination:=drg, DataType:=xlFixedWidth, _
          FieldInfo:=ttcColumnData, TrailingMinusNumbers:=True)
  On Error GoTo 0
  
  ' Inform.
  
  If ttc Then ' True
      MsgBox "Data parsed.", vbInformation
  Else ' Empty, due to the error
      MsgBox "Data not parsed.", vbExclamation
  End If