使用 VBA 将 Excel 列合并到一个工作表中

Question

我有多个工作表，它们的列数都相同，但行数不同。我需要从每个工作表中复制AS 列中的所有行，并将它们相互粘贴到一个新工作表中。当前列AS 包含一个公式=X2 & " " & AL2 & ""，它不允许我复制实际的“文本”并给我一个#ref! 错误。

我需要做的事情：从多个工作表中复制 AS 列，以便这些行相互堆叠。就是这样，没有公式只是文本。我修改了下面的代码，它可以工作，但我只是得到一个#ref! 错误。如果有人可以提供帮助，我将不胜感激！

Sub merge()
    Dim P As Integer

    On Error Resume Next

    Sheets(1).Select
    Worksheets.Add
    Sheets(1).Name = "Merged"
    Sheets(3).Activate
    Columns(45).Select
    Selection.Copy Destination:=Sheets(1).Range("A1")

    For P = 2 To Sheets.Count
        Sheets(P).Activate
        Range("A1").Select
        Selection.Columns(45).Select
        Selection.Copy Destination:=Sheets(1).Range("A1000000").End(xlUp)(2)
    Next
End Sub

Sub opensheets()
    Dim openfiles
    Dim x As Integer
    Dim selectversion As String
    selectversion = Worksheets("Settings").Range("C3").Value
    Dim ver As String

    If selectversion = "2003" Then
        ver = "xls"
    Else
        ver = "xlsx"
    End If

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    openfiles = Application.GetOpenFilename(FileFilter:="Microsoft Excel Files (*." & ver & "), *." & ver, MultiSelect:=True, Title:="Open Files")

    If TypeName(openfiles) = "Boolean" Then
        MsgBox "You need to select atleast one file"
        GoTo ExitHandler
    End If

    x = 1
    While x <= UBound(openfiles)
        Workbooks.Open Filename:=openfiles(x)
        Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        x = x + 1
    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

Answer 1

试试这个：

Sub merge()
    Dim Sh As Worksheet, ShM As Worksheet, i&, z&
    Application.ScreenUpdating = 0
    Set Sh = Worksheets.Add(, Sheets(Sheets.Count))
    Sh.Name = "consolidated"
    For Each ShM In ThisWorkbook.Worksheets
        If ShM.Name <> Sh.Name Then
            i = ShM.Cells(Rows.Count, 45).End(xlUp).Row
            z = Sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
            ShM.Activate: ShM.Range(Cells(1, 45), Cells(i, 45)).Copy
            Sh.Activate: Sh.Cells(z, 1).PasteSpecial xlPasteValues
        End If
    Next ShM
    Application.ScreenUpdating = 1
End Sub