在 MS Project 中，使用 VBA，我想根据 Excel 文件的内容在自定义字段之间移动数据

Question

我想移动各种自定义字段的内容，例如 Text1 -> Text2，然后 Text3 -> Text1。

我可以使用 VBA 中的一系列条目来完成此操作： 子传输_test_1()

Dim t As Task

For Each t In ActiveProject.Tasks
    t.Text2 = t.Text1
    t.Text1 = ""
Next t

CustomFieldRename FieldID:=pjCustomTaskText1, NewName:="test Field"

End Sub

但是，使用 Excel 工作表作为翻译源会更优雅。我使用了之前的answer作为打开Excel工作表并将其读入数组的基础，以便我可以循环遍历数组。

Sub GetValuesFromExcel()
'from https://stackoverflow.com/questions/66766996/how-to-pull-project-info-from-excel-into-ms-project-using-a-ms-project-macro

'code uses early binding to the Excel object library so you'll need to set a reference to
'that file (Tools Menu: References, check the box for the Microsoft Excel Object Library).


    Dim xl As Excel.Application
    Set xl = CreateObject("Excel.Application")
    xl.Visible = True
    
    Dim wbk As Excel.Workbook
    Set wbk = xl.Workbooks.Open("C:\Users\miles\OneDrive\Field Translations.xlsx", UpdateLinks:=False, ReadOnly:=True)
    
    Dim Dept As String
    Dim Customer As String
    Dept = wbk.Worksheets("Sheet1").Range("A2")
    Customer = wbk.Worksheets("Sheet1").Range("B2")
    
    'count how many rows
    lastrow = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    'lastrow = Worksheets("Sheet1").Range("A1000").End(xlUp).Row
    
    Dim DataArray As Variant
    DataArray = Worksheets("Sheet1").Range("A2:d" & lastrow)
    
    wbk.Close False
    xl.Quit
    For r = 1 To lastrow - 1
        For c = 1 To 4
            Debug.Print DataArray(r, c)
        Next c
    Next r
Dim t As Task

For Each t In ActiveProject.Tasks
Debug.Print "test of progress: " & t.ID & " - " & t.Name
    For r = 1 To lastrow - 1
        t.DataArray(r, 2) = t.DataArray(r, 1)
        t.DataArray(r, 1) = ""
    Next r
Next t
'For r = 1 To lastrow - 1
'    CustomFieldRename FieldID:=pjCustomTask & DataArray(r, 2), NewName:=DataArray(r, 4)
'Next r

    'ActiveProject.ProjectSummaryTask.SetField FieldNameToFieldConstant("Project Departments"), Dept
    'ActiveProject.ProjectSummaryTask.SetField FieldNameToFieldConstant("Customer"), Customer
    
End Sub

代码在

t.DataArray(r, 2) = t.DataArray(r, 1)

上失败 我怀疑它“读取”为 t."text2" = t."text1" 不起作用，但这只是一个猜测！

任何人都可以建议我如何才能完成这项工作吗？这种“优雅”的解决方案比直接将所有翻译输入 VBA 花费更多时间！然而，尝试自动化时经常出现这种情况，所以我宁愿不要放弃！ :)

非常感谢。

Answer 1

我想移动各种自定义字段的内容，例如 实例 Text1 -> Text2，然后 Text3 -> Text1。

使用 Excel 工作表作为源会更优雅 翻译。

此代码将打开一个 Excel 文件以获取将数据从一个字段移动到另一个字段（A 列和 C 列）的映射。然后它根据 Excel 文件中 B 和 D 列中的信息重命名字段。

Sub GetMappingsFromExcel()
    
    Dim xl As Excel.Application
    Set xl = CreateObject("Excel.Application")
    xl.Visible = True
    
    Dim wbk As Excel.Workbook
    Set wbk = xl.Workbooks.Open("C:\Users\miles\OneDrive\Field Translations.xlsx", UpdateLinks:=False, ReadOnly:=True)

    Dim wst As Excel.Worksheet
    Set wst = wbk.Worksheets("Sheet1")
    
    Dim Dept As String
    Dim Customer As String
    Dept = wst.Range("A2")
    Customer = wst.Range("B2")

    Dim lastrow As Long
    lastrow = wst.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    Dim Remapping As Variant
    Remapping = wst.Range("A2:D" & lastrow)
    
    ' Column A is the source field (eg Text1)
    ' Column B is the new name for the source field
    ' Column C is the destination field (eg Text2)
    ' Column D is the new name for the destination
    
    
    wbk.Close False
    xl.Quit
    
    Dim fldIDs() As PjField
    ReDim fldIDs(lastrow - 1, 2)
    Dim idxMap As Integer
    For idxMap = 0 To lastrow - 2
        fldIDs(idxMap, 0) = FieldNameToFieldConstant(Remapping(idxMap + 1, 1))
        fldIDs(idxMap, 1) = FieldNameToFieldConstant(Remapping(idxMap + 1, 3))
    Next idxMap
    
    Dim t As Task
    For Each t In ActiveProject.Tasks
        For idxMap = 0 To lastrow - 2
            t.SetField fldIDs(idxMap, 1), t.GetField(fldIDs(idxMap, 0))
        Next idxMap
    Next t


    For idxMap = 0 To lastrow - 2
        CustomFieldRename FieldID:=fldIDs(idxMap, 0), NewName:=CStr(Remapping(idxMap + 1, 2))
        CustomFieldRename FieldID:=fldIDs(idxMap, 1), NewName:=CStr(Remapping(idxMap + 1, 4))
    Next idxMap

    'ActiveProject.ProjectSummaryTask.SetField FieldNameToFieldConstant("Project Departments"), Dept
    'ActiveProject.ProjectSummaryTask.SetField FieldNameToFieldConstant("Customer"), Customer
    
End Sub