VBA to move rows to another sheet based on criteria

[JSR1306]

Hi all,

I am sorry if this has been explained already but I cant find anything that quite does what I want.

Basically I have a table as follows with about 1000 lines of data.

[TABLE="width: 100, align: center"]
<tbody>[TR]
[TD]Reference[/TD]
[TD]Priority[/TD]
[TD]status[/TD]
[TD]description[/TD]
[TD]due date[/TD]
[TD]date submitted[/TD]
[/TR]
[TR]
[TD]123[/TD]
[TD]2[/TD]
[TD]Open[/TD]
[TD]abc[/TD]
[TD]01/03/13[/TD]
[TD]11/02/13 [/TD]
[/TR]
[TR]
[TD]134[/TD]
[TD]2[/TD]
[TD]Open[/TD]
[TD]jhg[/TD]
[TD]02/03/13[/TD]
[TD]11/02/13[/TD]
[/TR]
[TR]
[TD]124[/TD]
[TD]1[/TD]
[TD]AWC [/TD]
[TD]kli[/TD]
[TD]01/03/13[/TD]
[TD]11/02/13[/TD]
[/TR]
[TR]
[TD]321[/TD]
[TD]3[/TD]
[TD]AWC[/TD]
[TD]ijk[/TD]
[TD]01/03/13[/TD]
[TD]11/02/13[/TD]
[/TR]
[TR]
[TD]526[/TD]
[TD]4[/TD]
[TD]Escalated[/TD]
[TD]yhu[/TD]
[TD]02/03/13[/TD]
[TD]11/02/13[/TD]
[/TR]
[TR]
[TD]981[/TD]
[TD]4[/TD]
[TD]Escalated[/TD]
[TD]jhy[/TD]
[TD]01/03/13[/TD]
[TD]11/02/13[/TD]
[/TR]
[TR]
[TD]852[/TD]
[TD]2[/TD]
[TD]Open[/TD]
[TD]abd[/TD]
[TD]01/03/13[/TD]
[TD]11/02/13[/TD]
[/TR]
</tbody>[/TABLE]

Basically I want to sort these into separate sheets under the headings of the status column. I have tried writing macros however this is very messy and I am sure there is a better way of coding it.

I have also tried some code such as the following:

Sub go()


Dim StsCol As String


Sheets("Report").Select


StsCol = Application.Range("A1000").End(xlUp).Row


a = 1




For i = 1 To StsCol

Sheets("Report").Select
If Range("C" & i).Value = "Open" Then
Range("C" & i).EntireRow.Copy
Sheets("T1 Open").Select
ActiveSheet.Range("A" & a).Select
Selection.PasteSpecial (xlValues)
a = a + 1
End If
Next

MsgBox "Done!"


End Sub


This does work on sorting the Open into a separate sheet, however, it is very slow and you the screen just blinks rapidly as it finds a row with Open and copies, then pastes it to the correct sheet.

I am not great a VB so any help is greatly appreciated. Hopefully I will learn something in the process

Many Thanks

John

 

[erik.van.geit]

Hi, hiker95,

I always like when it comes to "sport" You are writing "very fast" and I wanted to test it, so filled a sheet with about 20.000 rows but while writing this, it's still running. Not for you? Perhaps there is some setting to take care of?

The technique using "autofilter" achieved the task within 1 second even with 65.000 rows.

best regards,
Erik

PS: tried a few times: VBA blocked and I needed Task Manager to restart Excel

 

[erik.van.geit]

Hi, hiker95,

I always like when it comes to "sport" You are writing "very fast" and I wanted to test it, so filled a sheet with about 20.000 rows but while writing this, it's still running. Not for you? Perhaps there is some setting to take care of?

The technique using "autofilter" achieved the task within 1 second even with 65.000 rows.

best regards,
Erik

PS: tried a few times: VBA blocked and I needed Task Manager to restart Excel

 

[hiker95]

Brian R Armstrong,

Can the Sub DistributeRows() macro be adapted to run using the "Worksheet_Change(ByVal Target As Range)"

I would think that the DistributeRows is used best when there is a lot of data to move from one worksheet to others.

The Worksheet_Change event is usually triggered by a cell in a column, when that cell is changed. When that cell is changed you would want that row of data to be moved, not all the rows in the worksheet.

 

[hiker95]

Erik,

Thank you for your insight.

I was just trying a different way/method because I am interested in learning how to use the Scripting.Dictionary.

 

[erik.van.geit]

I was just trying a different way/method because I am interested in learning how to use the Scripting.Dictionary.

Thanks for your response, Hiker,
The code you posted might be OK on other systems, that's what I don't know: only reported what happened on my machine. Did you test it with a lot of rows?

 

[hiker95]

Erik,

Did you test it with a lot of rows?

No, just with the sample JSR1306 posted.

 

[hiker95]

Erik,

I am very impressed - AutoFilter 24,501 rows to three sheets in less than 1 second.

This is one for my archives.

Thank you very much.

 

[hiker95]

Team,

I have re-written my macro using arrays.

With the sample JSR1306 posted, duplicated down to row 24,501, my latest macro ran in 0.266 seconds, and Erick's ran in 0.469 seconds.

The additional worksheets already exist with their header/title rows.


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Option Explicit
Sub DisributeRowsArrays()
' hiker95, 02/14/2014
' http://www.mrexcel.com/forum/excel-questions/685493-visual-basic-applications-move-rows-another-sheet-based-criteria.html
Dim wR As Worksheet, wO As Worksheet, wA As Worksheet, wE As Worksheet
Dim r As Variant, o As Variant, a As Variant, e As Variant
Dim i As Long, lr As Long, rr As Long, oo As Long, aa As Long, ee As Long
Dim n As Long, nr As Long
Set wR = Worksheets("Report")
Set wO = Worksheets("Open")
Set wA = Worksheets("AWC")
Set wE = Worksheets("Escalated")
If wR.FilterMode Then wR.ShowAllData
r = wR.Range("A1").CurrentRegion.Resize(, 6)
n = Application.CountIf(wR.Columns(3), "Open")
ReDim o(1 To n, 1 To 6)
n = Application.CountIf(wR.Columns(3), "AWC")
ReDim a(1 To n, 1 To 6)
n = Application.CountIf(wR.Columns(3), "Escalated")
ReDim e(1 To n, 1 To 6)
For i = 1 To UBound(r, 1)
  If r(i, 3) = "Open" Then
    oo = oo + 1
    o(oo, 1) = r(i, 1)
    o(oo, 2) = r(i, 2)
    o(oo, 3) = r(i, 3)
    o(oo, 4) = r(i, 4)
    o(oo, 5) = r(i, 5)
    o(oo, 6) = r(i, 6)
  ElseIf r(i, 3) = "AWC" Then
    aa = aa + 1
    a(aa, 1) = r(i, 1)
    a(aa, 2) = r(i, 2)
    a(aa, 3) = r(i, 3)
    a(aa, 4) = r(i, 4)
    a(aa, 5) = r(i, 5)
    a(aa, 6) = r(i, 6)
  ElseIf r(i, 3) = "Escalated" Then
    ee = ee + 1
    e(ee, 1) = r(i, 1)
    e(ee, 2) = r(i, 2)
    e(ee, 3) = r(i, 3)
    e(ee, 4) = r(i, 4)
    e(ee, 5) = r(i, 5)
    e(ee, 6) = r(i, 6)
  End If
Next i
nr = wO.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wO.Range("A" & nr).Resize(UBound(o, 1), 6) = o
nr = wA.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wA.Range("A" & nr).Resize(UBound(a, 1), 6) = a
nr = wE.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wE.Range("A" & nr).Resize(UBound(e, 1), 6) = e
If wR.FilterMode Then wR.ShowAllData
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm


Then run the DisributeRowsArrays macro.

 

[erik.van.geit]

That's what's nice in live: some sport with fair-play

I've got results around 0.27 for mine and around 0.21 for your code, both quite stable.
NOTE: you used an array method

 

[Matheson843]

Hi,

I'm currently trying to perform the same process as the original post. Your VBA code works great in that it creates new sheets based on the data I'm trying to seperate in my "Projects" column. However, the code is only opening a new sheet and moving the header (row1) into the new sheet. I need to be able to move the corresponding rows over as well. Can you help?? I'm a VBA novice. Thanks!!

-Tim