下面的代码仅在一个工作簿中复制,我想打开多个文件并在一个工作表中复制,每个工作表中都有文件名。
我认为问题在于此: 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