Текст VBA Excel для данных столбца возвращает только одну строку

Question

Я борюсь с кодом, который постоянно возвращает только один velue. Мое количество строк является гибким. Иногда у меня 10, иногда 60, поэтому я не могу установить фиксированный диапазон. Конец (xlDown) тоже не помогает.

Чтобы примерно прояснить мою проблему, я показываю код и выводимое изображение ниже:

 Sub Texttocolumns()
 Columns("E:E").Insert

 Range("E1") = "SAO"
 Range("D2", Range("D2).End(xlDown)).Texttocolumns _
 Destination:=Range("D2"), DataType:=xlDelimited, Space:=True
 Columns("D").AutoFit
 Range("D2", Range("D2").End(xlDown)).Copy
 Range("D2", Range ("D2").End(xlToRight).End(xlDown)).PasteSpecial _
 Paste:=xlPasteFormats
 Application.CutCopyMode = True

 End Sub

Я попробовал другие способы, например, вместо Range("D2") Я поставил Range("D"), что не сработало. Так же, как и в Destination, где вместо Range ("D2") я поставил Range ("D2"). End (xlDown), что вызвало ошибку отладчика.

Как заставить весь этот список работать правильно?

Answer 1

A TextToColumns Ride

Комментарии должны помочь вам изменить код, где я неправильно понял. Если нет, не стесняйтесь спрашивать подробности в комментариях ниже.

Sub TextToCol()

    Const rowTitle As Long = 1        ' Title (Header) Row
    Const FR As Long = 2              ' First Record Row
    Const colSource As Long = 4       ' Source Column
    Const colTarget As Long = 5       ' Target Column
    Const strTitle As String = "SAO"  ' Target Column Title (Header)

    Dim rngCopy As Range              ' Source Record Range
    Dim rngPaste As Range             ' Paste Range
    Dim LR As Long                    ' Last Record Row
    Dim LC As Long                    ' Last Record Column

    ' Insert a new column (Target Column) after Source Column.
    Columns(colTarget).Insert
    ' Write Target Column Title.
    Cells(rowTitle, colTarget) = strTitle

    ' Calculate Last Record Row (from bottom to top) in Source Column.
    LR = Cells(Rows.Count, colSource).End(xlUp).Row
    ' Check if there are any records (data).
    If LR <= 1 Then MsgBox "No Records!": Exit Sub
    ' Calculate Source Record Range.
    Set rngCopy = Cells(FR, colSource).Resize(LR - FR + rowTitle)

    ' To avoid Excel complaining about data in cells when using TextToColumns,
    ' disable DisplayAlerts.
    Application.DisplayAlerts = False

        ' Apply TextToColumns on Source Record Range.
        rngCopy.TextToColumns Destination:=Cells(FR, colSource), _
          DataType:=xlDelimited, Space:=True

    ' Enable DisplayAlerts.
    Application.DisplayAlerts = True

    ' Apply Autofit on Source Column.and Target Columns.
    Columns(colSource).AutoFit
    ' Apply Autofit on Target Column.
    Columns(colTarget).AutoFit

    ' Calculate Last Record Column using Title Row.
    LC = Cells(rowTitle, Columns.Count).End(xlToLeft).Column

    ' Copy Source Record Range.
    rngCopy.Copy

    ' Calculate Paste Range.
    Set rngPaste = rngCopy.Offset(, colTarget - colSource) _
      .Resize(, LC - colTarget + 1)

    ' Paste formats of Source Record Range to Paste Range.
    rngPaste.PasteSpecial Paste:=xlPasteFormats

    ' Turn off CutCopyMode.
    Application.CutCopyMode = False

End Sub

Answer 2

Это должно сделать то, что вы ищете. Я прокомментировал, так что должно быть ясно, но не стесняйтесь задавать любые последующие вопросы ниже.

 Sub Texttocolumns()
 Dim wb As Workbook: Set wb = ThisWorkbook
 Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
 Dim LastRow As Long

 ws.Columns("E:E").Insert
 LastRow = ws.Range("D" & ws.Rows.Count).End(xlUp).Row

 ws.Range("E1") = "SAO"
 ws.Range(ws.Cells(2, 4), ws.Cells(LastRow, 4)).Texttocolumns Destination:=ws.Cells(2, 4), DataType:=xlDelimited, Space:=True
 ws.Columns("D").AutoFit
 ws.Range(ws.Cells(2, 4), ws.Cells(LastRow, 4)).Copy
 ws.Cells(2, 4).PasteSpecial

 Application.CutCopyMode = True

 End Sub