粘贴复制搞定不就行了

Sub RunOnAllXLSFiles()

' This macro copies the data inputs from into a separate workbook. It runs through all files in a specified folder


Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

On Error Resume Next

Set wbCodeBook = ThisWorkbook

    With Application.FileSearch.NewSearch
   
         
         'Change path if necessary
        .LookIn = "D:\User Data\My Documents\"
        .FileType = msoFileTypeExcelWorkbooks
        
            If .Execute > 0 Then 'check if there are Workbooks in folder
                For lCount = 1 To .FoundFiles.Count 'Loop through all.
                 'Open Workbook x and Set a Workbook variable to it
                 Set wbResults = Workbooks.Open(.FoundFiles(lCount))
                                 
                 'Copy the relevant sections

                    Sheets("Storage").Select
                  
                    'Columns("B:B").Select
                    Range("B1:B255").Select
                    Selection.Copy
                    
                    wbCodeBook.Activate
                    Sheets("Results").Select
                                        Rows(lCount + 1).Select
                    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                        :=False, Transpose:=True
                    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                        SkipBlanks:=False, Transpose:=True
                              
                 wbResults.Close SaveChanges:=True
                 
                 Application.StatusBar = "File " & lCount & " of " & .FoundFiles.Count & " files copied."
                 
                 Next lCount
            End If
    End With
   
    On Error GoTo 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True

End Sub

Use SAS to merge the data.

多个文件表合到一个文件表的多个SHEET中：
               Dim FilesToOpen, ft
        Dim x As Integer

        Application.ScreenUpdating = False
        On Error GoTo errhandler

        FilesToOpen = Application.GetOpenFilename _
        (FileFilter:="Micrsofe Excel文件(*.xls), *.xls", _
        MultiSelect:=True, Title:="要合并的文件")
        
        If TypeName(FilesToOpen) = "boolean" Then
        MsgBox "没有选定文件"
        'GoTo errhandler
        End If
        x = 1
        While x <= UBound(FilesToOpen)
        Set wk = Workbooks.Open(Filename:=FilesToOpen(x))
        wk.Sheets().Move after:=ThisWorkbook.Sheets _
        (ThisWorkbook.Sheets.Count)
        x = x + 1
        Wend

        MsgBox "合并成功完成！"

errhandler:
        'MsgBox Err.Description
        'Resume errhandler