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行，就向右移了。）

Answer 1

以下工作。我必须指定范围。

' 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

Answer 2

您应该阅读有关如何避免使用.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

选择单元格的通用分组（非静态）

2 个答案: