I am trying to do a basic thing but cannot get it right.
I want to evaluate the cells on sheet 2(New Roster) in a table column(OldNew) for the value "New". If it has the value, copy the entire row and add it to the table(CurrentRoster) on sheet 1(Current Roster).
Here is the code I am using:
For Each c In wb.Names("OldNew").RefersToRange.Cells
If c.Value Like "New" Then
On Error Resume Next
Set SourceTable = Worksheets("New Roster").ListObjects("NewRoster").DataBodyRange
Set DestinationTable = Worksheets("Current Roster").ListObjects("CurrentRoster").ListRows.Add
SourceTable.Copy
DestinationTable.Range.PasteSpecial xlPasteValues
End If
Next
This endlessly loops and does not do what I want.
Here is the entire code for context: Sub TableData()
Dim tbl As ListObject Dim cell As Range Dim rng As Range Dim RangeName As String Dim CellName As String Dim wb As Workbook, c As Range, m Dim ws1 As Worksheet Dim lr As Long Dim lo As ListObject Dim SourceTable Dim DestinationTable
Worksheets("New Roster").Activate Range("A1").Select
If Range("A1") = "" Then
MsgBox "No Data to Reconcile"
Exit Sub
Else
End If
Application.ScreenUpdating = False '---->Prevents screen flickering as the code executes.
Application.DisplayAlerts = False '---->Prevents warning "pop-ups" from appearing.
' Clears hidden columns from previous user
Worksheets("Current Roster").Activate
Range("A1").Activate
Columns.EntireColumn.Hidden = False
On Error Resume Next
Sheet1.ShowAllData
On Error GoTo 0
' Tables the New Roster
Worksheets("New Roster").Activate
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name _
= "NewRoster"
Range("NewRoster[#All]").Select
ActiveSheet.ListObjects("NewRoster").TableStyle = ""
' Name Ranges for Reference, New Name List From New Roster
ActiveSheet.Range("F2").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Names.Add Name:="NewNameList", RefersToR1C1:= _
"=NewRoster[Member AHCCCS ID]"
ActiveWorkbook.Names("NewNameList").Comment = "Contains New list to compare old list to"
' Compares CurrentNameList Values to NewNameList Values to verify if current names are still active
Set wb = ThisWorkbook
For Each c In wb.Names("CurrentNameList").RefersToRange.Cells
m = Application.Match(c.Value, wb.Names("NewNameList").RefersToRange, 0)
c.Offset(0, 26).Value = IIf(IsError(m), "InActive", "Active")
Next c
' Adds Column to New Roster Table and place Old/New in header cell
Worksheets("New Roster").Activate
Worksheets("New Roster").Range("AF1").Value = "Old/New"
' Names Old/New Range
ActiveSheet.Range("AF1").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Names.Add Name:="OldNew", RefersToR1C1:= _
"=NewRoster[Old/New]"
ActiveWorkbook.Names("OldNew").Comment = ""
' Compares CurrentNameList Values to NewNameList Values to determine if New Name, If so, Add to Current
Roster
For Each c In wb.Names("NewNameList").RefersToRange.Cells
m = Application.Match(c.Value, wb.Names("CurrentNameList").RefersToRange, 0)
c.Offset(0, 26).Value = IIf(IsError(m), "New", "Old")
Next c
' Move Rows with "New" from New Roster to Current Roster Worksheet
Worksheets("New Roster").Activate
For Each c In wb.Names("OldNew").RefersToRange.Cells
If c.Value Like "New" Then
On Error Resume Next
Set SourceTable = Worksheets("New Roster").ListObjects("NewRoster").DataBodyRange
Set DestinationTable = Worksheets("Current Roster").ListObjects("CurrentRoster").ListRows.Add
SourceTable.Copy
DestinationTable.Range.PasteSpecial xlPasteValues
End If
Next
' Clear New Roster Data
Worksheets("New Roster").Activate
Columns("A:A").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlToLeft
ActiveWorkbook.Names("NewNameList").Delete
ActiveWorkbook.Names("OldNew").Delete
Worksheets("Current Roster").Activate
Range("A1").Activate
ActiveSheet.Range("CurrentRoster[#All]").RemoveDuplicates Columns:=Array(1, 2, _
3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
30, 31 _
, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55), _
Header:=xlYes
Application.DisplayAlerts = True '---->Resets the default.
Application.ScreenUpdating = True '---->Resets the default.
End Sub
Aucun commentaire:
Enregistrer un commentaire