In MS Project, using VBA, I want to move data between custom fields based on the contents of an excel file

I want to move the contents of various custom fields around, for instance Text1 -> Text2 and then Text3 -> Text1.

I can do this using a series of entries in VBA: Sub transfer_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

However it would be more elegant to use an Excel sheet as the source of the translations. I have used a previous answer as the basis for opening and reading the excel sheet into an array so that I can loop through the array.

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

The code fails on the t.DataArray(r, 2) = t.DataArray(r, 1) I suspect it is "reading" as t."text2" = t."text1" which isn't working, however this is just a guess!

Can anyone suggest how I can make this work? This "elegant" solution is taking more time than just entering all the translations directly into VBA! However, this is often the case with attempts at automation, so I would prefer not to give up! :)

Many thanks.

I want to move the contents of various custom fields around, for instance Text1 -> Text2 and then Text3 -> Text1.

it would be more elegant to use an Excel sheet as the source of the translations.

This code will open an Excel file to get the mappings for moving data from one field to another (columns A & C). And then it renames the fields based on information in columns B & D in the Excel file.

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