Copy rows based on cell value and paste on a new sheet with same cell value name

Question

I have a DATA sheet containing an employee list with 3 columns,

COLUMN A - DEPARTMENT
COLUMN B - EMPCODE
COLUMN C - EMPNAME

Here is sample data:

I want to split the contents of this sheet according to COLUMN A - DEPARMENT and place them on different sheets, the new sheets to be named as the department name in Column A.

The end result should be something like this:

This code checks each row. If the cell in Column A is equal to the cell below, it selects the row.

Sub CopyRows()

    Dim rngMyRange As Range, rngCell As Range
    With Worksheets("DATA")
     Set rngMyRange = .Range(.Range("a1"), .Range("A65536").End(xlUp))

     For Each rngCell In rngMyRange
            If rngCell.Value = rngCell.Offset(1, 0).Value Then
            rngCell.EntireRow.Select
         End If

     Next
         Selection.Copy
         Sheets.Add After:=ActiveSheet
         Rows("1:1").Select
         Selection.Insert Shift:=xlDown
         ActiveSheet.Name = Range("A1")
 End With

 End Sub

How can I make the selection stay and add more selected rows as it checks the cell value in Column A?

Answer 1

you can use RemoveDuplicates() and Autofilter() methods of Range object as follows:

Option Explicit

Sub CopyRows()
    Dim rngCell As Range
    Dim depSheet As Worksheet

    With Worksheets("DATA") '<--|refer to data sheet
        .Rows(1).Insert '<--|insert a temporary header row: it'll be used for AutoFilter() method and eventually deleted
        .Cells(1, 1).value = "Department" '<--| place a dummy header in the temporary header row
        With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Offset(, .UsedRange.Columns.Count) '<--| refer to a "helper" column out of the used range and limited to column "A" last non empty row
            .value = .Offset(, -.Parent.UsedRange.Columns.Count).value '<--| duplicate departments (column "A") values in helper one
            .RemoveDuplicates Columns:=Array(1), header:=xlYes '<--| leave only departments unique values in "helper" column
            For Each rngCell In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--|loop through "helper" column departments unique values
                Set depSheet = GetSheet(.Parent.Parent, rngCell.value) '<--|get or add the worksheet corresponding to current department
                With .Offset(, -.Parent.UsedRange.Columns.Count + 1) '<--|refer to departments column
                    .AutoFilter field:=1, Criteria1:=rngCell.value '<--| filter it on current department value
                    With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) '<--| refer to department filtered cells
                        depSheet.Cells(depSheet.Rows.Count, 1).End(xlUp).Offset(1).Resize(.Cells.Count, 3).value = .Resize(, 3).value '<--|copy their values along with columns "B" and "C" ones into first empty row of the corresponding worksheet
                    End With
                End With
            Next rngCell
            .ClearContents '<--| clear "helper" column
        End With
        .AutoFilterMode = False
        .Rows(1).Delete '<--| delete temporary header row
    End With
 End Sub

Function GetSheet(wb As Workbook, shtName As String) As Worksheet
    On Error Resume Next
    Set GetSheet = wb.Worksheets(shtName) '<--| try and set a sheet with passed name
    On Error GoTo 0
    If GetSheet Is Nothing Then '<--| if there weas no such sheet...
        Set GetSheet = wb.Worksheets.Add(After:=ActiveSheet) '<--|... add a new sheet
        With GetSheet
            .Name = shtName '<--|rename it after passed name
            .Range("A1:C1").value = Array("DEPARTMENT", "EMPCODE", "EMPNAME") '<--| add headers
        End With
    End If
End Function

Answer 2

I've created this VBA to copy data from one sheet (source) to another sheet (target) based on conditional data given in 3rd sheet (condition):

Sub CopyYes()
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet
    Dim Condition As Worksheet


    Set Source = ActiveWorkbook.Worksheets("source")
    Set Target = ActiveWorkbook.Worksheets("target")
    Set Condition = ActiveWorkbook.Worksheets("condition")

    j = 1    'This will start copying data to Target sheet at row 1
      For Each d In Condition.Range("A1:A86")
        For Each c In Source.Range("B2:B1893")
            If d = c Then
                Source.Rows(c.Row).Copy Target.Rows(j)
                j = j + 1
            End If
        Next c
      Next d
End Sub

Answer 3

You've put together a pretty good question. It has a clear description of the starting point and what the objective is. The code you have is a good start towards the answer. However I didn't try to group a bunch of rows together like you wanted to do because I had no idea of how to do that. What I did was to loop through the DATA range and then deal with each row one at a time. If the destination worksheet existed, I inserted the row after the last row. If the destination sheet did not exist, I created the new sheet the way you were doing. Step through this with the debugger and you'll be able to see how it works.

Sub CopyRows()

Dim rngMyRange As Range, rngCell As Range
Dim sht As Worksheet
Dim LastRow As Long
Dim SheetName As String



With Worksheets("DATA")
Set rngMyRange = .Range(.Range("a1"), .Range("A65536").End(xlUp))

    For Each rngCell In rngMyRange

        rngCell.EntireRow.Select

        Selection.Copy

        If (WorksheetExists(rngCell.Value)) Then
            SheetName = rngCell.Value
            Sheets(SheetName).Select
            Set sht = ThisWorkbook.Worksheets(SheetName)
            LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).row
            Rows(LastRow + 1).Select
            Selection.Insert Shift:=xlDown
        Else
            Sheets.Add After:=ActiveSheet
            Rows("1:1").Select
            Selection.Insert Shift:=xlDown
            ActiveSheet.Name = rngCell.Value
        End If


        'Go back to the DATA sheet
        Sheets("DATA").Select
    Next

End With

End Sub

Function WorksheetExists(sName As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function

Answer 4

Thanks for all your replies. I actually found a pretty good code that does exactly what I wanted, I forgot to note down the reference site though. Here's the code if anyone's interested:

    Sub parse_data()

    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    vcol = 1
    Set ws = Sheets("DATA")
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1:J1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
    ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
    Next
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
    Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
    Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
    Sheets(myarr(i) & "").Columns.AutoFit
    Next
    ws.AutoFilterMode = False
    ws.Activate
    End Sub

Answer 5

But Eileen, If we need to copy cell values of COLUMN E, rather than COLUMN A and paste on new sheet, then your ref code still lists values from COLUMN A......! So we need just to change vcol = 5 on line 9

Answer 6

I modified user3598756's answer above to bypass restrictions on the max length allowed for the name of a sheet. It will concatenate the first and last 13 characters of the name with 4 dots in between

Option Explicit

Sub CopyRows()
    Dim rngCell As Range
    Dim depSheet As Worksheet
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    With Worksheets("DATA") '<--|refer to data sheet
        .Rows(1).Insert '<--|insert a temporary header row: it'll be used for AutoFilter() method and eventually deleted
        .Cells(1, 1).Value = "Table_Name" '<--| place a dummy header in the temporary header row
        With .Range("A1", .Cells(.Rows.count, 1).End(xlUp)).Offset(, .UsedRange.Columns.count) '<--| refer to a "helper" column out of the used range and limited to column "A" last non empty row
            .Value = .Offset(, -.Parent.UsedRange.Columns.count).Value '<--| duplicate departments (column "A") values in helper one
            .RemoveDuplicates Columns:=Array(1), Header:=xlYes '<--| leave only departments unique values in "helper" column
            For Each rngCell In .Range("A2:A" & .Cells(.Rows.count, 1).End(xlUp).Row) '<--|loop through "helper" column departments unique values
                Set depSheet = GetSheet(.Parent.Parent, rngCell.Value) '<--|get or add the worksheet corresponding to current department
                With .Offset(, -.Parent.UsedRange.Columns.count + 1) '<--|refer to departments column
                    .AutoFilter field:=1, Criteria1:=rngCell.Value '<--| filter it on current department value
                    With .Offset(1).Resize(.Rows.count - 1).SpecialCells(xlCellTypeVisible) '<--| refer to department filtered cells
                        depSheet.Cells(depSheet.Rows.count, 1).End(xlUp).Offset(1).Resize(.Cells.count, 3).Value = .Resize(, 3).Value '<--|copy their values along with columns "B" and "C" ones into first empty row of the corresponding worksheet
                    End With
                End With
            Next rngCell
            .ClearContents '<--| clear "helper" column
        End With
        .AutoFilterMode = False
        .Rows(1).Delete '<--| delete temporary header row
    End With
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
 End Sub

Function GetSheet(wb As Workbook, shtName As String) As Worksheet
    On Error Resume Next
    Set GetSheet = wb.Worksheets(shtName) '<--| try and set a sheet with passed name
    On Error GoTo 0
    If GetSheet Is Nothing Then '<--| if there weas no such sheet...
        Dim count As Long
        count = Len(shtName)
        Dim newName As String
        If count > 30 Then
            newName = Left(shtName, 13) & "...." & Right(shtName, 13)
        Else
            newName = shtName
        End If
        Set GetSheet = wb.Worksheets.Add(After:=ActiveSheet) '<--|... add a new sheet
        With GetSheet
            .Name = newName '<--|rename it after passed name
            .Range("A1:C1").Value = Array("DEPARTMENT", "EMPCODE", "EMPNAME") '<--| add headers
        End With
    End If
End Function