打开多个项目文件并复制到一个 Excel 文件中 - 如何操作？

Question

下面的代码仅在一个工作簿中复制，我想打开多个文件并在一个工作表中复制，每个工作表中都有文件名。

我认为问题在于此： Set s = Xl.Workbooks(BookNam).Worksheets(1)

Sub Export_Notes_Text_NBL()
Dim UniqueIDs() As Integer
Dim TskNam() As String
Dim Start() As Date
Dim Finish() As Date
Dim TskNot() As String
Dim NumTsk As Integer, i As Integer, j As Integer, RowIndex As Integer
Dim BookNam As String
Dim t As Task
Dim Xl As Excel.Application
Dim s As Worksheet
Dim c As Range
'set array sizes based on number of tasks in file
SelectTaskColumn
NumTsk = ActiveSelection.Tasks.Count
ReDim UniqueIDs(NumTsk), TskNam(NumTsk), ResNam(NumTsk), Start(NumTsk), Finish(NumTsk)
ReDim TskNot(NumTsk)

'First, gather desired data from Project in arrays
 
Application.Caption = "Progress"
ActiveWindow.Caption = " Gathering Project data into arrays"
i = 1
For Each t In ActiveSelection.Tasks
    If Not t Is Nothing Then
        UniqueIDs(i) = t.UniqueID
        TskNam(i) = t.Name
        Start(i) = t.Start
        Finish(i) = t.Finish
         
         i = i + 1
    End If
Next t
 
'Second, set up existing instance of Excel, or if Excel is not running, start it
On Error Resume Next
Set Xl = GetObject(, "Excel.application")
If Err <> 0 Then
    On Error GoTo 0
    Set Xl = CreateObject("Excel.Application")
    If Err <> 0 Then
        MsgBox "Excel application is not available on this workstation" _
            & vbCr & "Install Excel or check network connection", vbCritical, _
            "Notes Text Export - Fatal Error"
        FilterApply Name:="all tasks"
        Set Xl = Nothing
        On Error GoTo 0     'clear error function
        Exit Sub
    End If
End If
On Error GoTo 0
Xl.Workbooks.Add
ActiveSheet.Paste
BookNam = Xl.ActiveWorkbook.Name
   
'Keep Excel in the background and minimized until export is done (speeds transfer)
'NOTE: Items with a 'Reference annotation will not work without a reference to the Excel object library
Xl.Visible = True

Xl.ScreenUpdating = True

Xl.DisplayAlerts = True

ActiveWindow.Caption = " Writing data to worksheet"
'Third, dump arrays into the Workbook
Set s = Xl.Workbooks(BookNam).Worksheets(1)
ActiveWindow.Caption = " do it again"
s.Range("A1").Value = "UniqueID"
s.Range("B1").Value = "Task Name"
s.Range("C1").Value = "Start"
s.Range("D1").Value = "Finish"
s.Range("E1").Value = "Res Names"
s.Range("F1").Value = "Notes"
Set c = s.Range("A2")
RowIndex = 0
For j = 1 To i - 1
    c.Offset(RowIndex, 0).Value = UniqueIDs(j)
    c.Offset(RowIndex, 1).Value = TskNam(j)
    c.Offset(RowIndex, 2).Value = Start(j)
    c.Offset(RowIndex, 3).Value = Finish(j)
    c.Offset(RowIndex, 4).Value = ResNam(j)
    c.Offset(RowIndex, 5).Value = TskNot(j)
    RowIndex = RowIndex + 1
Next j
'Fourth, format the Workbook
s.Rows(1).Font.Bold = True
s.Columns("A").AutoFit
s.Columns("C:D").AutoFit
s.Columns("C:D").NumberFormat = "d/m/yy;@"
s.Columns("B").columnwidth = 25
s.Columns("E").columnwidth = 25
s.Columns("F").columnwidth = 80
s.Range("B:B,E:F").WrapText = True
s.Columns("A:F").VerticalAlignment = xlTop 'reference
s.Range("C:D").HorizontalAlignment = xlLeft 'reference
'Finally, close and exit
MsgBox "Data Export is complete", vbOKOnly, "Notes Text Export"
Application.Caption = ""
ActiveWindow.Caption = ""
Xl.Visible = True
Xl.ScreenUpdating = True
Set Xl = Nothing
End Sub
'This utility will print out the current object library references to the Immediate Window.
Sub Chk_ObjLib_Refs()
Dim oRef As Object
For Each oRef In ThisProject.VBProject.References
    Debug.Print oRef.Description
    Debug.Print oRef.fullpath
Next
End Sub
'This utility will find and remove all line feeds that may be present in the Notes field
'   It will also report via the Immediate Window where it found the line feeds and how many
Sub remove_LFs()
Dim TstStr As String, NewStr As String
Dim p1 As Integer, LFcntr As Integer
Dim t As Task
For Each t In ActiveProject.Tasks
    If Not t Is Nothing Then
        If Len(t.Notes) > 0 Then
        Debug.Print "ID " & t.ID & " - " & Len(t.Notes) & " chars"
            NewStr = ""
            TstStr = t.Notes
            LFcntr = 0
            While InStr(1, TstStr, vbCr) > 0
                LFcntr = LFcntr + 1
                p1 = InStr(1, TstStr, vbCr)
                NewStr = NewStr & Mid(TstStr, 1, p1 - 1)
                TstStr = Mid(TstStr, p1 + 1)
            Wend
            t.Notes = NewStr & TstStr
            Debug.Print " found " & LFcntr & " line feeds"
            Debug.Print " ID now has " & Len(t.Notes) & " chars"
        End If
    End If
Next t
End Sub