copying block of rows based on cell value to another sheet

[Worker8ee]

Hello everyone, I have searched for this answer for an hour and a half now and have found threads treating this issue but all answers are customized to the specific question asker's needs and I can't figure out how to translate them to my needs. Here is my issue: I have a main sheet titled "AllDepts" which contains 20,000 rows. Column T specifies which department number each row belongs to, the whole sheet is sorted so that all of the same department numbers are grouped together. I need to copy all of the rows that have the same department number in column T to a new sheet. There are 20 different department numbers so I will end up with 20 different sheets that have isolated each department. Department 1 will go to sheet1, department 2 will go to sheet2 and so on. I have found a VBA that does this but it goes line by line and takes a long time to finish, is there any way to make this VBA more efficient so that it identifies the whole block of rows that have the same value in Column T and copies/pastes them in one swoop instead of going line by line? Here is the tediously slow VBA that I am currently using:
　
Sub DistDepts()
For Each Cell In Sheets(1).Range("T:T")
If Cell.Value = "1" Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
　
Sheets("Sheet1").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("AllDepts").Select
End If
Next
End Sub

 

[mrshl9898]

This looks to be working, how does it suit the need? Only limit I can think of if if you hit a cell with no department numbr

Sub test()


Dim shtnam As String
Dim rownum1 As Long
Dim rownum2 As Long
Dim deptno As Long


rownum1 = 1
rownum2 = 1
deptno = 1


Do Until deptno = 21 Or Sheets("AllDepts").Cells(rownum2, 20).Value = ""


    Do Until Sheets("AllDepts").Cells(rownum1, 20).Value = deptno
    rownum1 = rownum1 + 1
    Loop


    Do Until Sheets("AllDepts").Cells(rownum2, 20).Value = deptno + 1 Or Sheets("AllDepts").Cells(rownum2, 20).Value = ""
    rownum2 = rownum2 + 1
    Loop


shtnam = "Sheet" & deptno
Sheets("AllDepts").Rows(rownum1 & ":" & rownum2 - 1).Copy Sheets(shtnam).Range("A1")


deptno = deptno + 1
Loop


End Sub

 

[Worker8ee]

Thank you for your quick response, I get an error 400 when I try to run this, I am not sure what is causing that error. On a separate note I noticed the VBA you so graciously supplied doesn't have any coding for column T and other columns might use the same number as the department numbers in column T so I believe this would need to specify it should only be looking at column T for the criteria.

 

[Worker8ee]

Whoops I realize that column T is specified by the number 20, sorry it has been a long day. I will try to research why the error 400 is coming up thanks again for your help.

 

[mrshl9898]

You're welcome.

I haven't seen a 400 before, it did test ok on 2013.

 

[Worker8ee]

A million thank yous you have saved me countless hours of work. The 400 was a user error issue where I had an extra column inserted that was throwing off the department values by a column. This is perfect I appreciate you taking the time out of your day to help!