Excel VBA 将 Sheet 中的每一列复制到右侧的下一列

Question

我需要完成一些非常简单的事情：将一个完整的专栏复制到同一作品右侧的下一专栏sheet（我在一个 sheet 的一个 sheet 中有大约 300 个这样的专栏工作簿）意味着宏必须将范围内的每个奇数列复制到下一个偶数列，以便我最终得到一个充满重复列的范围。我知道我需要部分或全部使用以下公式：

cells(selection.row, columns.Count).end(xltoleft).offset(,1).select

完整的宏是什么？搜索每个可用的板，只找到具有自定义条件的解决方案。我的应该很简单。感谢您的意见。

Answer 1

尝试（可能需要一些错误处理）。我没有复制整列，而是使用 A 列来确定 sheet 中的最后一行数据（您可以更改它），然后循环偶数列，将它们设置为等于先前的奇数列。

Option Explicit

Sub test()

    Dim loopRange As Range

    Set loopRange = ThisWorkbook.ActiveSheet.Columns("A:AE")

    Dim lastRow As Long

    With ThisWorkbook.ActiveSheet

        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

    End With

    Dim currentColumn As Long

    With loopRange

        For currentColumn = 2 To .Columns.Count Step 2

            .Range(.Cells(1, currentColumn), .Cells(lastRow, currentColumn)) = .Range(.Cells(1, currentColumn - 1), .Cells(lastRow, currentColumn - 1)).Value

        Next currentColumn

    End With

End Sub

如果你知道最后一行：

 Option Explicit

    Sub test()

        Dim loopRange As Range

        Set loopRange = ThisWorkbook.ActiveSheet.Columns("A:AE")

        Const lastRow As Long = 108

        Dim currentColumn As Long

        With loopRange

            For currentColumn = 2 To .Columns.Count Step 2

                .Range(.Cells(1, currentColumn), .Cells(lastRow, currentColumn)) = .Range(.Cells(1, currentColumn - 1), .Cells(lastRow, currentColumn - 1)).Value

            Next currentColumn

        End With

    End Sub

Answer 2

我不完全确定我理解了这个问题，但请在下面找到建议。代码可能有点乱，因为我用的是录制的宏：

Sub CopyRows()

Range("A1").Activate

While Not IsEmpty(ActiveCell)
    ActiveCell.Columns("A:A").EntireColumn.Select
    Selection.Copy
    ActiveCell.Offset(0, 1).Columns("A:A").EntireColumn.Select
    Selection.Insert Shift:=xlToRight
    ActiveCell.Offset(0, 1).Range("A1").Select
Wend

End Sub

Answer 3

如果您希望通过在右侧插入每一列的副本来基本上复制每一列，我认为您需要以下代码。

即这会复制列：

A | B | C 
---------
A | B | C 
1 | 2 | 3

到

A | B | C | D | E | F
---------------------
A | A | B | B | C | C
1 | 1 | 2 | 2 | 3 | 3

VBA

Option Explicit

Sub CopyAllColsOneToRight()

    Dim ws As Worksheet
    Dim lastCol As Long
    Dim lastRow As Long
    Dim currentCopyCol As Long

    Application.ScreenUpdating = False 'optimise performance by not updating the screen as we move stuff
    Set ws = ActiveSheet
    lastCol = GetLastUsedColumn(ws).Column
    lastRow = GetLastUsedRow(ws).Row

    For currentCopyCol = lastCol To 1 Step -1
        CopyColumnInsertRight ws, lastRow, currentCopyCol
        'CopyColumn ws, lastRow, currentCopyCol, lastRow, currentCopyCol * 2
        'CopyColumn ws, lastRow, currentCopyCol, lastRow, currentCopyCol * 2 - 1
    Next

End Sub

Sub CopyColumnInsertRight(ByRef ws As Worksheet, fromLastRow, fromCol)
    Dim fromRange As Range
    Set fromRange = ws.Range(ws.Cells(1, fromCol), ws.Cells(fromLastRow, fromCol))
    fromRange.Copy
    fromRange.Insert Shift:=XlDirection.xlToRight
End Sub

'Sub CopyColumn(ByRef ws As Worksheet, fromLastRow, fromCol, toLastRow, toCol)
'   Dim fromRange As Range
'   Dim toRange As Range
'   Set fromRange = ws.Range(ws.Cells(1, fromCol), ws.Cells(fromLastRow, fromCol))
'   Set toRange = ws.Range(ws.Cells(1, toCol), ws.Cells(toLastRow, toCol))
'   toRange.Value2 = fromRange.Value2
'End Sub

Function GetLastUsedColumn(ByRef ws As Worksheet) As Range
    Set GetLastUsedColumn = ws.Cells.Find( _
        What:="*" _
        , After:=ws.Cells(1, 1) _
        , LookIn:=XlFindLookIn.xlFormulas _
        , LookAt:=XlLookAt.xlPart _
        , SearchOrder:=XlSearchOrder.xlByColumns _
        , SearchDirection:=XlSearchDirection.xlPrevious _
        , MatchCase:=False _
    )
End Function

Function GetLastUsedRow(ByRef ws As Worksheet) As Range
    Set GetLastUsedRow = ws.Cells.Find( _
        What:="*" _
        , After:=ws.Cells(1, 1) _
        , LookIn:=XlFindLookIn.xlFormulas _
        , LookAt:=XlLookAt.xlPart _
        , SearchOrder:=XlSearchOrder.xlByRows _
        , SearchDirection:=XlSearchDirection.xlPrevious _
        , MatchCase:=False _
    )
End Function

代码注释：

我们禁用屏幕更新；这避免了在宏运行时刷新 UI，从而使过程更有效率。
我们得到了最后填充的列，这样我们就可以将复制的列限制为产生差异的列（即使用少于全部列数的电子表格更快；这将大多数情况下都是如此）
我们得到了最后填充的行，这样我们就不会复制整个列，而是只复制填充的行。我们可以检查每行最后使用的单元格，但这可能效率较低，因为通常最后一行对于范围内的大多数列都是相同的。此外，在使用插入方法时，需要确保 xlToRight 不会导致单元格移入错误的列。
我们的 for 循环有 Step -1，因为如果我们从左到右，我们会在复制其他列时覆盖右侧的列（例如，将 A 复制到 B 会覆盖 B 中的内容，然后当我们复制 B 时到 C 我们实际上是在复制副本）。相反，我们向后工作，以便我们始终复制到空白列或我们之前复制的列。
我提供了一个仅复制值（比复制格式更快）的注释掉的版本，以及另一个使用 Insert 创建新列的版本。一个可能比另一个表现更好，但到目前为止我还没有测试过（注意：副本必须复制两倍的单元格，因为它不保留原件但创建 2 个副本，而插入方法保留原件并插入右侧的副本，但有复制格式化数据的额外开销）。

Excel VBA 将 Sheet 中的每一列复制到右侧的下一列

Excel VBA to Copy Every Column in a Sheet to the Next Column to the Right

excel

vba

batch-processing

VBA