Thanks Thanks:  0
Likes Likes:  0
Page 1 of 3 123 LastLast
Results 1 to 10 of 29

Thread: VBA to move rows to another sheet based on criteria

  1. #1
    New Member JSR1306's Avatar
    Join Date
    Sep 2012
    Location
    Portsmouth, Hampshire
    Posts
    45
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Post VBA to move rows to another sheet based on criteria

    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.

    Reference Priority status description due date date submitted
    123 2 Open abc 01/03/13 11/02/13
    134 2 Open jhg 02/03/13 11/02/13
    124 1 AWC kli 01/03/13 11/02/13
    321 3 AWC ijk 01/03/13 11/02/13
    526 4 Escalated yhu 02/03/13 11/02/13
    981 4 Escalated jhy 01/03/13 11/02/13
    852 2 Open abd 01/03/13 11/02/13

    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

  2. #2
    MrExcel MVP erik.van.geit's Avatar
    Join Date
    Feb 2003
    Location
    Belgium 3272 Testelt
    Posts
    17,832
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA to move rows to another sheet based on criteria

    Hi,

    This tempted me
    Try this code
    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
    I love Jesus

    email Erik

    founder of DRAFT

    my free Addins
    Table-It download & info
    Formula Translator 04

  3. #3
    Board Regular texasalynn's Avatar
    Join Date
    May 2002
    Location
    Houston, TX
    Posts
    8,457
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA to move rows to another sheet based on criteria

    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

    Code:
    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

  4. #4
    Board Regular
    Join Date
    Apr 2009
    Location
    Northeast PA, USA
    Posts
    17,623
    Post Thanks / Like
    Mentioned
    15 Post(s)
    Tagged
    6 Thread(s)

    Default Re: VBA to move rows to another sheet based on criteria

    Jsr1306,
    Have a great day,
    hiker95

    Windows 10, Excel 2007, on a PC.

  5. #5
    New Member JSR1306's Avatar
    Join Date
    Sep 2012
    Location
    Portsmouth, Hampshire
    Posts
    45
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA to move rows to another sheet based on criteria

    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

  6. #6
    MrExcel MVP erik.van.geit's Avatar
    Join Date
    Feb 2003
    Location
    Belgium 3272 Testelt
    Posts
    17,832
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA to move rows to another sheet based on criteria

    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
    I love Jesus

    email Erik

    founder of DRAFT

    my free Addins
    Table-It download & info
    Formula Translator 04

  7. #7
    Board Regular
    Join Date
    Apr 2009
    Location
    Northeast PA, USA
    Posts
    17,623
    Post Thanks / Like
    Mentioned
    15 Post(s)
    Tagged
    6 Thread(s)

    Default Re: VBA to move rows to another sheet based on criteria

    Jsr1306,


    Sample raw data:


    Excel 2007
    ABCDEF
    1ReferencePrioritystatusdescriptiondue datedate submitted
    21232Openabc1/3/201311/2/2013
    31342Openjhg2/3/201311/2/2013
    41241AWCkli1/3/201311/2/2013
    53213AWCijk1/3/201311/2/2013
    65264Escalatedyhu2/3/201311/2/2013
    79814Escalatedjhy1/3/201311/2/2013
    88522Openabd1/3/201311/2/2013
    9

    Report








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


    Excel 2007
    ABCDEF
    1ReferencePrioritystatusdescriptiondue datedate submitted
    21232Openabc1/3/201311/2/2013
    31342Openjhg2/3/201311/2/2013
    48522Openabd1/3/201311/2/2013
    5

    Open







    Excel 2007
    ABCDEF
    1ReferencePrioritystatusdescriptiondue datedate submitted
    21241AWCkli1/3/201311/2/2013
    33213AWCijk1/3/201311/2/2013
    4

    AWC







    Excel 2007
    ABCDEF
    1ReferencePrioritystatusdescriptiondue datedate submitted
    25264Escalatedyhu2/3/201311/2/2013
    39814Escalatedjhy1/3/201311/2/2013
    4

    Escalated



    Have a great day,
    hiker95

    Windows 10, Excel 2007, on a PC.

  8. #8
    Board Regular
    Join Date
    Apr 2009
    Location
    Northeast PA, USA
    Posts
    17,623
    Post Thanks / Like
    Mentioned
    15 Post(s)
    Tagged
    6 Thread(s)

    Default Re: VBA to move rows to another sheet based on criteria

    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).


    Code:
    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).
    Last edited by hiker95; Feb 13th, 2013 at 06:04 PM.
    Have a great day,
    hiker95

    Windows 10, Excel 2007, on a PC.

  9. #9
    Board Regular
    Join Date
    Jun 2007
    Posts
    87
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA to move rows to another sheet based on criteria

    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

  10. #10
    Board Regular
    Join Date
    Jun 2007
    Posts
    87
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA to move rows to another sheet based on criteria

    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

Some videos you may like

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •