copy and paste row (lookup) to another worksheet

[user5566]

Currently what this code does is check Column C value in 'Master' sheet and will copy over to matching worksheet name.

I would like to improve on this code using sort of lookup feature.

I have this new table
[TABLE="width: 500"]
<tbody>[TR]
[TD]ColA[/TD]
[TD]ColB[/TD]
[/TR]
[TR]
[TD]ID1[/TD]
[TD]East[/TD]
[/TR]
[TR]
[TD]ID2[/TD]
[TD]West[/TD]
[/TR]
[TR]
[TD]ID3[/TD]
[TD]North[/TD]
[/TR]
</tbody>[/TABLE]

If Column C match the value of Col A, copy row to worksheet with ColB value.
Eg. A row contain ID1 at column C in Master worksheet, it will be copied over to 'East' worksheet. Assume all the worksheets with ColB values have been created.

Option Explicit


Const NA_WS As String = "NA"    'Create sheet "NA" if it doesn't exist


Public Sub DistributeData()
    Const MASTER_WS As String = "Master"
    Const MASTER_COL As String = "C"    'AutoFilter column in Master sheet


    Dim wb As Workbook
    Set wb = Application.ThisWorkbook
    Dim ws As Worksheet, lr As Long, lc As Long, ur As Range, fCol As Range, done As Range
    With wb.Worksheets(MASTER_WS)
        lr = .Cells(.Rows.Count, MASTER_COL).End(xlUp).Row
        lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
        Set ur = .Range(.Cells(3, 1), .Cells(lr, lc))
        Set fCol = .Range(.Cells(2, MASTER_COL), .Cells(lr, MASTER_COL))
        Set done = .Range(.Cells(1, MASTER_COL), .Cells(2, MASTER_COL))
    End With


    Application.ScreenUpdating = False
    For Each ws In wb.Worksheets
        If ws.Name <> MASTER_WS And ws.Name <> NA_WS Then
            fCol.AutoFilter Field:=1, Criteria1:=ws.Name
            If fCol.SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
                UpdateWs ws, ur
                Set done = Union(done, fCol.SpecialCells(xlCellTypeVisible))
            End If
        End If
    Next
    If wb.Worksheets(MASTER_WS).AutoFilterMode Then
        fCol.AutoFilter
        UpdateNA done, ur
    End If
    Application.ScreenUpdating = True
End Sub

Private Sub UpdateWs(ByRef ws As Worksheet, ByRef fromRng As Range)
    fromRng.Copy
    With ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0)
        .PasteSpecial xlPasteAll
    End With
    ws.Activate
    ws.Cells(1).Select
End Sub


Private Sub UpdateNA(ByRef done As Range, ByRef ur As Range)
    done.EntireRow.Hidden = True
    If ur.SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
        UpdateWs ThisWorkbook.Worksheets(NA_WS), ur.SpecialCells(xlCellTypeVisible)
    End If
    done.EntireRow.Hidden = False
    Application.CutCopyMode = False
    ur.Parent.Activate
End Sub

Option Explicit


Const NA_WS As String = "NA"    'Create sheet "NA" if it doesn't exist


Public Sub DistributeData()
    Const MASTER_WS As String = "Master"
    Const MASTER_COL As String = "C"    'AutoFilter column in Master sheet


    Dim wb As Workbook
    Set wb = Application.ThisWorkbook
    Dim ws As Worksheet, lr As Long, lc As Long, ur As Range, fCol As Range, done As Range
    With wb.Worksheets(MASTER_WS)
        lr = .Cells(.Rows.Count, MASTER_COL).End(xlUp).Row
        lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
        Set ur = .Range(.Cells(3, 1), .Cells(lr, lc))
        Set fCol = .Range(.Cells(2, MASTER_COL), .Cells(lr, MASTER_COL))
        Set done = .Range(.Cells(1, MASTER_COL), .Cells(2, MASTER_COL))
    End With


    Application.ScreenUpdating = False
    For Each ws In wb.Worksheets
        If ws.Name <> MASTER_WS And ws.Name <> NA_WS Then
            fCol.AutoFilter Field:=1, Criteria1:=ws.Name
            If fCol.SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
                UpdateWs ws, ur
                Set done = Union(done, fCol.SpecialCells(xlCellTypeVisible))
            End If
        End If
    Next
    If wb.Worksheets(MASTER_WS).AutoFilterMode Then
        fCol.AutoFilter
        UpdateNA done, ur
    End If
    Application.ScreenUpdating = True
End Sub

Private Sub UpdateWs(ByRef ws As Worksheet, ByRef fromRng As Range)
    fromRng.Copy
    With ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0)
        .PasteSpecial xlPasteAll
    End With
    ws.Activate
    ws.Cells(1).Select
End Sub


Private Sub UpdateNA(ByRef done As Range, ByRef ur As Range)
    done.EntireRow.Hidden = True
    If ur.SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
        UpdateWs ThisWorkbook.Worksheets(NA_WS), ur.SpecialCells(xlCellTypeVisible)
    End If
    done.EntireRow.Hidden = False
    Application.CutCopyMode = False
    ur.Parent.Activate
End Sub

 

[user5566]

realised the duplicate code section, but unable to edit..