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,

This tempted me
Try this code

Sub FilterToSheets()
'Erik Van Geit
'1302013 2118
'lacks error handling when sheet doesn't exist
'clearing sheets and pasting with columnheaders
Dim SourceSheet As Worksheet
Dim TargetSheet As Worksheet
Dim SheetNames As Variant
Dim i As Long
Dim LR As Long

'EDIT
Set SourceSheet = Sheets("WhatEverName")
SheetNames = Array("Open", "AWC", "Escalated")
Const FilterColumn = 3
'END EDIT

    With SourceSheet
    LR = .Range("A" & .Rows.Count).End(xlUp).Row
    
        For i = 0 To UBound(SheetNames)
        Set TargetSheet = Worksheets(SheetNames(i))
        TargetSheet.Cells.ClearContents
        
            With .Range("A1:F" & LR)
            .AutoFilter Field:=FilterColumn, Criteria1:=SheetNames(i)
            .Offset(0, 0).Copy TargetSheet.Range("A1")
            End With
        Next i

    End With

End Sub

kind regards,
Erik

 

[texasalynn]

this is a macro I use to breakout data based on what is in column A and the sheet name is "ALL". With some slight modifications this could work

Sub breakout()
Workbooks(1).Activate
Dim lastCol As Integer, LastRow As Long, x As Long
Dim rng As Range, Rng1 As Range, Rng2 As Range, Rng3 As Range
Dim SheetNameArray, fn As WorksheetFunction
Dim CalcSetting As Integer
Dim newsht As Worksheet
Set fn = Application.WorksheetFunction
 
With Application
    CalcSetting = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With
 
With Sheets("All")
    Set rng = .UsedRange
    Set Rng1 = Intersect(rng, .Range("A:A"))
    lastCol = rng.Column + rng.Columns.Count - 1
 
    .Range("A:A").AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=.Cells(1, lastCol + 2), Unique:=True
 
    Set Rng2 = Intersect(.Columns(lastCol + 2).CurrentRegion, _
    .Rows("2:" & Rows.Count))
 
    ReDim SheetNameArray(1 To Rng2.Cells.Count)
    SheetNameArray = fn.Transpose(Rng2)
    .Columns(lastCol + 2).Clear
 
    For x = LBound(SheetNameArray) To UBound(SheetNameArray)
        On Error Resume Next
        Set newsht = ThisWorkbook.Sheets(CStr(SheetNameArray(x)))
            If Err <> 0 Then
                Worksheets.Add
                ActiveSheet.Name = CStr(SheetNameArray(x))
                Err.Clear
            End If
        On Error GoTo 0
            rng.AutoFilter Field:=1, Criteria1:=SheetNameArray(x)
            Set Rng3 = Intersect(rng, .Cells.SpecialCells(xlCellTypeVisible))
            Rng3.Copy Workbooks(1).Sheets(CStr(SheetNameArray(x))).Range("A1")
            rng.AutoFilter
     Next x
End With
Range("A1").Select
Application.Calculation = CalcSetting
 
End Sub

 

[hiker95]

Jsr1306,

 

[JSR1306]

Thanks Erik,

I made a few tweaks for my actual data and it works instantly, much better than the route I was going down

Many Thanks

John

 

[erik.van.geit]

You're welcome!

See if you can keep the macro recorder as your friend and then go beyond: get rid of all kinds of "select", use filter instead of loop, etcetera...
If you want to add sheets during code, in case there are new criteria, take a look at texasalynns code.

best regards,
Erik

 

[hiker95]

Jsr1306,


Sample raw data:

Excel 2007
	A	B	C	D	E	F
1	Reference	Priority	status	description	due date	date submitted
2	123	2	Open	abc	1/3/2013	11/2/2013
3	134	2	Open	jhg	2/3/2013	11/2/2013
4	124	1	AWC	kli	1/3/2013	11/2/2013
5	321	3	AWC	ijk	1/3/2013	11/2/2013
6	526	4	Escalated	yhu	2/3/2013	11/2/2013
7	981	4	Escalated	jhy	1/3/2013	11/2/2013
8	852	2	Open	abd	1/3/2013	11/2/2013
9
Report

After the macro (the three additional worksheets must already exist):

Excel 2007
	A	B	C	D	E	F
1	Reference	Priority	status	description	due date	date submitted
2	123	2	Open	abc	1/3/2013	11/2/2013
3	134	2	Open	jhg	2/3/2013	11/2/2013
4	852	2	Open	abd	1/3/2013	11/2/2013
5
Open

Excel 2007
	A	B	C	D	E	F
1	Reference	Priority	status	description	due date	date submitted
2	124	1	AWC	kli	1/3/2013	11/2/2013
3	321	3	AWC	ijk	1/3/2013	11/2/2013
4
AWC

Excel 2007
	A	B	C	D	E	F
1	Reference	Priority	status	description	due date	date submitted
2	526	4	Escalated	yhu	2/3/2013	11/2/2013
3	981	4	Escalated	jhy	1/3/2013	11/2/2013
4
Escalated

 

[hiker95]

Jsr1306,


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 DistributeRows()
' hiker95, 02/13/2013
' http://www.mrexcel.com/forum/excel-questions/685493-visual-basic-applications-move-rows-another-sheet-based-criteria.html
' The original code by MickG, 12/20/2012, has been modified.
Dim d As Range, Rng As Range, It As Range, nr As Long, k
Application.ScreenUpdating = False
Set Rng = Sheets("Report").Range(Range("C2"), Range("C" & Rows.Count).End(xlUp))
With CreateObject("Scripting.Dictionary")
  .CompareMode = vbTextCompare
  For Each d In Rng
    If Not .Exists(d.Value) Then
      .Add d.Value, d.EntireRow
    Else
      Set .Item(d.Value) = Union(.Item(d.Value), d.EntireRow)
    End If
  Next
  For Each k In .keys
    For Each It In .Item(k).Areas
      nr = Sheets(k).Range("A" & Rows.Count).End(xlUp).Offset(1).Row
      Sheets(k).Range("A" & nr).Resize(It.Rows.Count, ActiveSheet.Columns.Count) = It.Value
    Next It
  Next k
End With
Application.ScreenUpdating = False
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 DistributeRows macro (very fast).

 

[Brian R Armstrong]

Can the Sub DistributeRows() macro be adapted to run using the "Worksheet_Change(ByVal Target As Range)" i.e. update the status on the relevant sheet automatically?

I have been struggling with this for ages

Appreciate any help

Brian A

 

[Brian R Armstrong]

Can the Sub DistributeRows() macro be adapted to run using the "Worksheet_Change(ByVal Target As Range)" i.e. update the status on the relevant sheet automatically?

I have been struggling with this for ages

Appreciate any help

Brian A