Question

我想在像D2这样的单元格上运行宏....将D2作为活动单元格。我可以一次在所有单元格上运行宏来获得结果..使用下面的代码我可以只在一个单元格上运行宏

Sub Allocation()

'
' Allocation Macro
'
' Keyboard Shortcut: Ctrl+g
'
    Selection.TextToColumns Destination:=ActiveCell, DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
        Semicolon:=True, Comma:=True, Space:=True, Other:=True, FieldInfo:= _
        Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), _
        TrailingMinusNumbers:=True
    ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    ActiveCell.Offset(-1, 4).Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    ActiveCell.Offset(1, -1).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveCell.Offset(-1, -3).Range("A1:C1").Select
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=ActiveCell.Range("A1:C16"), Type:= _
        xlFillDefault
    ActiveCell.Range("A1:C16").Select
    ActiveCell.Offset(0, 4).Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.ClearContents
End Sub

Answer 1

我并不是100％清楚你所追求的是什么，但这会在一开始就选择一系列细胞：

Sub Allocation()

'
' Allocation Macro
'
' Keyboard Shortcut: Ctrl+g
'
Dim r As Range, c
Set r = Selection
For c = 1 To r.Count
    r(c).Select
      Selection.TextToColumns Destination:=ActiveCell, DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
        Semicolon:=True, Comma:=True, Space:=True, Other:=True, FieldInfo:= _
        Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), _
        TrailingMinusNumbers:=True
      ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
      ActiveCell.Offset(-1, 4).Range("A1").Select
      Range(Selection, Selection.End(xlToRight)).Select
      Selection.Copy
      ActiveCell.Offset(1, -1).Range("A1").Select
      Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
          False, Transpose:=True
      ActiveCell.Offset(-1, -3).Range("A1:C1").Select
      Application.CutCopyMode = False
      Selection.AutoFill Destination:=ActiveCell.Range("A1:C16"), Type:= _
          xlFillDefault
      ActiveCell.Range("A1:C16").Select
      ActiveCell.Offset(0, 4).Range("A1").Select
      Range(Selection, Selection.End(xlToRight)).Select
      Selection.ClearContents
Next
End Sub

在不同的单元格上运行宏

1 个答案: