Выберите общую группировку (не статическую) ячеек

Question

У меня есть текущий макрос Excel ниже, который отлично работает для один набор данных:

Sub test_macro()
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1)), _
        TrailingMinusNumbers:=True
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Cut Destination:=Range("B1:K1")
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
End Sub

Цель состоит в том, чтобы взять набор данных, который выглядит следующим образом:

И преобразуйте это в следующее:

| COL1 | COL2 | COL3 | COL4 | COL5 | COL6 | COL7 | COL8 | COL9 | COL10 |
|------|------|------|------|------|------|------|------|------|-------|
| Foo1 | Foo2 | Foo3 | Foo4 | Foo5 | Foo6 | Foo7 | Foo8 | Foo9 | Foo10 |

И это прекрасно работает как есть.Однако количество столбцов у меня может измениться.Иногда это только 2 столбца, иногда до 250 столбцов.Поэтому меня беспокоит часть моего макроса Range(Selection, Selection.End(xlToRight)).Select Selection.Cut Destination:=Range("B1:K1"), так как он указывает диапазон вставки B1:K1.

Следовательно, как я могу сделать этот диапазон назначения универсальным?(Я просто перемещаюсь по строке 1 на 1 вправо для каждой заполненной ячейки в строке 1).

Answer 1

Вы должны прочитать о том, как избежать использования .Select ... В противном случае я не уверен, что число запятых ",," может варьироваться между вашими столбцами (в этом случае требуется лучшее управление заменой), но в качестве рабочего примера, основанного на вашем образце, приведенное ниже должно работать с любым количеством столбцов / строк.Смотрите комментарии в коде для более подробной информации:

Option Explicit
Sub splitColumns()

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

Dim databook As Workbook
Set databook = Application.Open("dummy_wip.xlsx") 'Can allocate directly to the variable on .Open

Dim ws As Worksheet: Set ws = databook.Worksheets("SheetName") 'Best to declare the worksheet objects too
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row 'get the last row
Dim arrSplit() As String, strToSplit As String
Dim R As Long

With ws
    For R = 2 To lRow   'loop through all values
        strToSplit = Replace(.Cells(R, 1), ",,", ",") 'Replace 2 commas with 1... if you might have more than 2 at once, you will need a better replace
        If Left(strToSplit, 1) = "," Then strToSplit = Right(strToSplit, Len(strToSplit) - 1) 'Get rid of leading comma if any

        arrSplit = Split(strToSplit, ",") 'split the values at comma
        .Range(.Cells(R, 2), .Cells(R, UBound(arrSplit) + 2)) = arrSplit    'Allocate the values back to the spreadsheet in column B
    Next R
End With

With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

End Sub

Answer 2

Сработало следующее. Я должен был указать диапазоны.

' This sub opens the workbook
Sub Open_WB()
' Turn off screen updating
Application.ScreenUpdating = False
' Open data
Workbooks.Open "dummy_wip.xlsx"
' Activate data
Dim databook As Workbook
Set databook = Application.Workbooks("dummy_wip.xlsx")

MsgBox ("Got here")

' Format the data per Michelle Barstad Requirements
  Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1)), _
        TrailingMinusNumbers:=True

    ' Dynamically look for resizing
    Dim seltocut As Range
    Dim seltopaste As Range
    Dim cellstart As Range
    Dim cellfinish As Range

    Set cellstart = Cells(1, 1)
    Set cellfinish = Cells(1, 2)
    Set seltocut = Range(cellstart, cellstart.End(xlToRight))

    Range("B1").Select
    Set seltopaste = Range(cellfinish, cellfinish.End(xlToRight).Offset(, 1))

    seltocut.Cut Destination:=seltopaste
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft



End Sub