How do I copy and paste entire row only when cell equals sheet/tab name?

Question

I need help with one aspect of my VBA code. I have a Master worksheet that houses data on all of my customers. I currently have code that looks at Column B (Customer Name Column) and creates new worksheets/tabs for each unique customer. I then want to cut and paste every row from my Master worksheet into individual respective worksheets based on the customer name. I've included a picture of my Master worksheet. I've also included the code I'm currently working with is below, it creates the new tabs but won't copy and paste.

Sub CreateWSandCopyPaste()

Application.ScreenUpdating = False
        
    Dim cell As Range
    Dim thisSheetName As String
    AWS = ActiveSheet.Name
    'Creates new worksheet/tab for every unique value in Column B (Customer Code Column)
    For Each cell In Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
        If (cell.Value <> "") Then
            If (IsSheetExist(cell.Value) = False) Then
                Worksheets.Add after:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = cell.Value
            End If
        End If
    Next
  
'Copy and paste value A:U if the value in column B matches the tab name
Dim ws As Worksheet
For Each ws In Sheets

If ActiveSheet.Range("B2").Value = ws.Name Then
ActiveSheet.Range("A:U").CurrentRegion.Copy Destination:=ws.Range("A:U" & Rows.Count).End(x1Up)

 
End If
Next

Application.ScreenUpdating = True

End Sub

Private Function IsSheetExist(ByVal newSheetName As String)
    Dim ws As Worksheet
    For Each ws In Worksheets
        If (ws.Name = newSheetName) Then
            IsSheetExist = True
            Exit Function
        End If
    Next
    ' ---
    IsSheetExist = False
End Function

Master Worksheet - Customer Column

Tim Williams Tim Williams · Accepted Answer · 2020-07-28T16:23:42

You can do it like this:

Sub CreateWSandCopyPaste()
    
    Dim cell As Range, v
    Dim thisSheetName As String, wb As Workbook, ws As Worksheet
    
    Application.ScreenUpdating = False
        
    Set ws = ActiveSheet
    Set wb = ws.Parent
    
    'Creates new worksheet/tab for every unique value in Column B (Customer Code Column)
    For Each cell In ws.Range(ws.Range("B2"), ws.Range("B" & Rows.Count).End(xlUp)).Cells
        v = cell.Value
        If Len(v) > 0 Then cell.EntireRow.Range("A1:U1").Copy _
             GetSheet(v, wb).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            
    Next
    Application.ScreenUpdating = True

End Sub

'Return a named sheet in wb (or create if doesn't exist)
Private Function GetSheet(ByVal SheetName As String, wb As Workbook)
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = wb.Worksheets(SheetName)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count))
        ws.Name = SheetName
    End If
    Set GetSheet = ws
End Function

How do I copy and paste entire row only when cell equals sheet/tab name?

1 Answers