CODEWITHSUNDEEP
vbaexcel
Hwee7
Hwee7

Reputation: 45

copy rows from 1 source worksheet to worksheets that match the worksheet name

I have a master worksheet that contains data with many columns. Next I have also created multiple worksheets from a list.

Now, I would like to copy the rows from the master worksheet to the respective worksheets if the value in the column matches against all the worksheet name, else copy to an 'NA' sheet.

Previously I could only think of hardcoding, but it is not feasible because the number of worksheets may increase to 50+, so I need some help on how I can achieve this..

'find rows of master sheet
    With sh
        LstR = .Cells(.Rows.Count, "C").End(xlUp).Row    'find last row of column C
        Set rng = .Range("C3:C" & LstR)    'set range to loop
    End With

'start the loop
'loop through, then loop through each C cell in template. if cell.value == worksheet name, copy to respective worksheet... elseif... else copy to NA
For Each c In rng.Cells
    If c = "WEST" Then
            c.EntireRow.Copy wsl1.Cells(wsl1.Rows.Count, "A").End(xlUp).Offset(1)    'copy row to first empty row in WEST

        ElseIf c = "PKM" Then
        c.EntireRow.Copy wsl2.Cells(wsl2.Rows.Count, "A").End(xlUp).Offset(1)

        Else
        c.EntireRow.Copy wsl7.Cells(wsl7.Rows.Count, "A").End(xlUp).Offset(1)

        End If

    Next c

Thanks to @user9770531, I was able to do what I want for the macro.

However, now I would like to make the macro more flexible. For example, I have this additional table in another worksheet with ColA_id and ColB_group

Instead of just matching checking worksheet name against the values in column C, I would like to do this: if the master file column C matches "ColA_id", copy the data to respective "ColB_group" worksheets. Assuming ColB_group have been used to create the worksheet names.

Upvotes: 0

Views: 294

Answers (1)

user9770531
user9770531

Reputation: 41

Use code bellow - all subs in the same (standard) module

It searches Master.ColumnC for each sheet name (except Master and NA)
Uses AutoFilter for each sheet name, and copies all rows at once
All rows not assigned to a specific sheet will be copied to NA

It assumes sheet NA is already created, with Headers

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

Upvotes: 0

Related Questions