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

I have multiple worksheets, they all have the same number of columns but not the same number of rows. I need to copy all rows from column AS, from each worksheet and paste them on top of each other into a new worksheet. The current column AS contains a formula =X2 & " " & AL2 & "" which is not allowing me to copy the actual "text" and giving me a #ref! error.

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

What I need to happen: Copy column AS from multiple worksheets so the rows just stack on top of one another. That's all, no formulas just the text. I modified the below code, it works but I just get a #ref! error. I'd be grateful if someone could help!

我需要做的是:从多个工作表中复制列，这样行就会叠在一起。就是这样，没有公式，只有文本。我修改了下面的代码，它可以工作，但是我得到了#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

1 个解决方案

#1

Try this:

试试这个:

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