Блог

Я пытаюсь для каждого и продолжаю сталкиваться с этим несоответствием типов. Именованные диапазоны ограничены рабочей книгой.

Намерение: для каждой ячейки в столбце «Статус», если = «Неактивный», скопируйте и вставьте «A: AF» на вкладку «Неактивный» в следующую пустую ячейку.

Код проблемы:

 For Each i In Sheet1.ListObjects("CurrentRoster").ListColumns("Status").DataBodyRange
        If Sheet1.ListObjects("CurrentRoster").ListColumns("Status").DataBodyRange.Value = "InActive" 
Then
        Range("A2", Range("AF" amp; Rows.Count).End(xlUp)).Copy Sheet3.Range("A" amp; Rows.Count).End(xlUp)(1)
    End If
 Next
  

Вот вся операция.

 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 i As Range

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
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
    
' Move Row with "Inactive" from Current Roster to Inactive Worksheet
 Worksheets("Current Roster").Activate
 
 For Each i In Sheet1.ListObjects("CurrentRoster").ListColumns("Status").DataBodyRange
        If Sheet1.ListObjects("CurrentRoster").ListColumns("Status").DataBodyRange.Value = "InActive" Then
        Range("A2", Range("AF" amp; Rows.Count).End(xlUp)).Copy Sheet3.Range("A" amp; Rows.Count).End(xlUp)(1)
    End If
 Next
 
 
 Worksheets("Current Roster").Activate
 On Error Resume Next
 Sheet1.ListObjects("CurrentRoster").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
 On Error GoTo 0
 Sheet1.ListObjects("CurrentRoster").AutoFilter.ShowAllData
 
' 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"
 
' 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 Row with "New" from New Roster to Current Roster Worksheet
    Worksheets("New Roster").Activate
    Sheet2.ListObjects("NewRoster").Range.AutoFilter 32, "New"
    Range("A2", Range("AF" amp; Rows.Count).End(xlUp)).Copy Sheet1.Range("A" amp; Rows.Count).End(xlUp)(1)

 ' 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
 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
  

Здесь многое происходит, и это собрано воедино. Не стесняйтесь жарить. Я пытаюсь учиться.