vba - Have two tables active and completed move active to completed w/ macro need to copy newly created hyperlinks on two columns any help is appreciated

Question

I have two tables of projects: Active and Completed (marked as F for final) Recently added hyperlinks to two columns I want to copy the hyperlink from the active table to the completed table I have attempted to use ActiveSheet.PasteSpecial xlPasteAll code however I am not sure where to place it in the existing code below to make it work?

Sub RemoveFstatus()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim tblCurrent, tblComplete As ListObject
Set tblCurrent = Sheets("All District 3 Projects").ListObjects("AllProjects")
Set tblComplete = Sheets("Completed Projects").ListObjects("tblCompleted")

'remove current filters
ActiveSheet.ShowAllData

'clear the current table sorts
tblCurrent.Sort.SortFields.Clear

'Sort to line up status for deletion
Dim columnName As Range
Set columnName = Range("AllProjects[[#All],[Status]]")
tblCurrent.Sort.SortFields.Add Key:=columnName, SortOn:=xlSortOnValues, Order:=xlAscending, 
DataOption:=xlSortNormal
With tblCurrent.Sort
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

'filter to show only f status projects
tblCurrent.Range.AutoFilter Field:=tblCurrent.ListColumns("Status").Index, _
    Criteria1:=Array("F", "f"), Operator:=xlFilterValues
    
'Select only the visible rows, columns FIN NO to Est.Finnish. Do not select the columns with Date 
headers
Range("AllProjects[[Financial Project No.]:[Estimated 
Finish]]").SpecialCells(xlCellTypeVisible).Select

If Not Selection.EntireRow.Hidden Then 'Copy the project info to move to the Completed Projects sheet

    Sheets("Completed Projects").Activate
    tblComplete.ListRows.Add 1
    tblComplete.Range.Cells(2, 1).Select
    
    Sheets("All District 3 Projects").Activate
    Selection.Copy
    
    Sheets("Completed Projects").Activate
    Application.ActiveCell.PasteSpecial xlPasteValues
    
    ''''''''''''''''''''''''''''''''''''''''''''
    'Cut record from table at this point
    ''''''''''''''''''''''''''''''''''''''''''''
    Sheets("All District 3 Projects").Activate
    Application.CutCopyMode = False

    'turn off the delete warning
    Application.DisplayAlerts = False
    
    'delete transfered record(s)
    tblCurrent.DataBodyRange.Delete
    
    'turn warnings back on
    Application.DisplayAlerts = True


    ResetTable.ResetTable
    
    MsgBox "All F Status projects have been moved."
    Else

    ResetTable.ResetTable
    
    MsgBox "There are no F status projects to move."
    
   End If

  'Format the monthly projection below the projects table
   FormatMonthlyProjection

   Application.Calculation = xlCalculationAutomatic
   Application.EnableEvents = True
   Application.ScreenUpdating = True

 End Sub

 Sub FormatMonthlyProjection()
'Format the row heights for the monthly projections under the main projects table
'The monthly projection is a named range "MonthlyProjection"

Dim I As Integer 'counter
Dim mp As Range 'Monthly Projection range

Set mp = Range("MonthlyProjection")

I = 0
While I < 20
    mp(I + 1, 1).RowHeight = 20
    mp(I + 2, 1).RowHeight = 81
    mp(I + 3, 1).RowHeight = 107
    mp(I + 4, 1).RowHeight = 20
    mp(I + 5, 1).RowHeight = 20
    I = I + 5
Wend

End Sub

Function FIXME()
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Function

Answer 1

等待大神答复