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
与恶龙缠斗过久,自身亦成为恶龙;凝视深渊过久,深渊将回以凝视…