☰

VBA 宏用于交换列

tag-icon • tag-icon microsoft-excel vba
VBA 宏用于交换列

请您帮助我使用 VBA 宏来交换列

例如有 4 列

供应商 1、供应商 2、供应商得分 1、供应商得分 2

我想更改以下列

供应商 1、供应商得分 1、供应商 2、供应商得分 2

我已经使用了下面的代码

列（“I：I”）。选择所选内容。剪切列（“D：D”）。选择所选内容。插入 Shift：=xlToRight

答案1

您可能会发现我在此处的迷你博客中发布的代码有些有趣......

http://www.excelfox.com/forum/f22/swapping-rearranging-multiple-columns-of-data-493/

答案2

您的规范并不完全清楚。但您似乎想将列的前半部分与后半部分交错。这可以在 VBA 中相当简单快速地完成。我已经做出了假设，您需要编辑这些假设，即原始数据的位置以及您想要放置结果的位置。我还假设数据是连续的，如代码注释中所述。

这是在 VBA 数组中实现的，因为重复访问工作表的例程要慢得多。

所用的算法：

  • 将数据读入二维变量数组
  • 创建第二个数组来保存结果，大小与第一个数组相同
  • 通过交错第一半列范围和第二半列范围来填充第二个数组。
  • 将结果数组写入工作表范围。
  • 格式化结果
Option Explicit
Sub InterleaveColumns()
    Dim wsORIG As Worksheet, wsRESULT As Worksheet, rRESULT As Range
    Dim lNumCols As Long
    Dim vORIG As Variant, vRESULT() As Variant
    Dim I  As Long, J As Long

'Place Results starting on Sheet3!A1
Set wsRESULT = Worksheets("Sheet3")
Set rRESULT = wsRESULT.Cells(1, 1)

'Assuming the data table starts Sheet2!A1 and is contiguous
'Adjust algorithm as required
Set wsORIG = Worksheets("Sheet2")

'Place data into a 2D Variant Array
vORIG = wsORIG.Cells(1, 1).CurrentRegion

'Number of columns
lNumCols = UBound(vORIG, 2)

'Sanity check
If lNumCols Mod 2 <> 0 Then
    MsgBox ("Must have Even number of columns")
    Exit Sub
End If

'Create results array
ReDim vRESULT(1 To UBound(vORIG, 1), 1 To UBound(vORIG, 2))

'Populate results array with interleaving
For I = 1 To UBound(vORIG, 1)
    For J = 1 To UBound(vORIG, 2) / 2
        vRESULT(I, (J - 1) * 2 + 1) = vORIG(I, J)
        vRESULT(I, (J - 1) * 2 + 2) = vORIG(I, J + lNumCols / 2)
    Next J
Next I

'Write results array to some worksheet and range
Set rRESULT = rRESULT.Resize(UBound(vRESULT, 1), UBound(vRESULT, 2))
With rRESULT
    .EntireColumn.Clear
    .Value = vRESULT
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With

End Sub

相关内容