CODEWITHSUNDEEP
vbaexcel
Brian
Brian

Reputation: 23

Excel VBA copy entire row to new sheet based off cell data

I am very new to Excel VBA and need some help. I have a list of data that I would like to copy to a new sheet based off the data in column B and copy the entire row to a new sheet of the same name.

Column B
2nd Black
1st Black
1st Brown
2nd Brown
3rd Brown

I've changed my code and came up with this. Everything Is working. Thanks for your help.

Sub create_role()
Dim c As Range
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim m As Integer
Dim Source As Worksheet
Dim Target As Worksheet

Set Source = ActiveWorkbook.Worksheets("master")

j = 11
k = 11
l = 11
m = 11

For Each c In Source.Range("b11:b110")
    If (c = "5th Black" Or c = "4th Black" Or c = "3rd Black" Or c = "2nd Black" Or c = "1st Black" Or c = "Jr. Black") Then
       Set Target = ActiveWorkbook.Worksheets("BLACK")
       Source.Rows(c.Row).Copy Target.Rows(j)
    ElseIf c = "1st Brown" Then
        Set Target = ActiveWorkbook.Worksheets("1ST BROWN")
        Source.Rows(c.Row).Copy Target.Rows(k)
        k = k + 1
    ElseIf c = "2nd Brown" Then
        Set Target = ActiveWorkbook.Worksheets("2ND BROWN")
        Source.Rows(c.Row).Copy Target.Rows(l)
        l = l + 1
    ElseIf c = "3rd Brown" Then
        Set Target = ActiveWorkbook.Worksheets("3RD BROWN")
        Source.Rows(c.Row).Copy Target.Rows(m)
        m = m + 1
    End If

    j = j + 1

Next c

End Sub

Upvotes: 0

Views: 566

Answers (1)

user4039065
user4039065

Reputation:

Any references to a worksheet by its Worksheet .Name property is case insensitive and you can take advantage of that.

Option Explicit

Sub create_role()
    Dim src As String, trgtws As String, c As Range

    With ActiveWorkbook.Worksheets("master")

        For Each c In .Range(.Cells(11, "B"), .Cells(Rows.Count, "B").End(xlUp))
            trgtws = vbNullString
            src = StrConv(c.Value2, vbProperCase)
            Select Case True
                Case src Like "*Black"
                    trgtws = "BLACK"
                Case src Like "*Brown"
                    trgtws = UCase(src)
                Case Else
                    'do nothing
            End Select

            If CBool(Len(trgtws)) Then
                With .Parent.Worksheets(trgtws)
                    c.EntireRow.Copy _
                      Destination:=.Cells(.Cells(Rows.Count, "B").End(xlUp).Row, "A")
                End With
            End If
        Next c

    End With
End Sub

I've changed your criteria method to a Select Case statement that should make expansion to more conditions easier but your IF ... ElseIf ... End If could be used here.

The destination location assumes that there is some sort of column header label in B10 of each worksheet if there are no values below that.

Upvotes: 1

Related Questions