• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 37
  • Last Modified:

Macro to move rows to another sheet

I am looking for a macro that moves rows in the 'Current' tab (from columns A to M) with the Status that say "Closed" and "Solved" to the 'Closed' tab. I also want to standardize that status column to just read "Open" if it reads any of these fields below.

Open - Web Update Entered
Open - Research
Open - Relief Await Cust Veri.
Open - Cust. Action Req.
Open - Eng Activity
Open - Scheduling

I've attached the file as well to this.
Workbook1.xlsx
0
AckeemK
Asked:
AckeemK
  • 4
  • 2
1 Solution
 
Saurabh Singh TeotiaCommented:
You can use the following code to do what you are looking for...

Sub changestatus()
    Dim lr As Long
    Dim cell As Range, rng As Range
    Dim ws As Worksheet

    Set ws = Sheets("Current")

    lr = ws.Cells(Cells.Rows.Count, "A").End(xlUp).Row

    If lr > 1 Then

        Set rng = ws.Range("E2:E" & lr)

        For Each cell In rng
            If InStr(1, cell.Value, "open", vbTextCompare) > 0 Then cell.Value = "Open"
        Next cell

    End If
End Sub

Open in new window


Saurabh...
0
 
Saurabh Singh TeotiaCommented:
Also the above macro just changing the status only from whatever value to open..what i understand you want to move sheet values as well from current to closed where value is closed or solved then use this... code..

Sub changestatus()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

    Dim lr As Long
    Dim cell As Range, rng As Range
    Dim ws As Worksheet, lr1 As Long
    Dim r As Range, ws1 As Worksheet


    Set ws = Sheets("Current")
    Set ws1 = Sheets("Closed")
    lr = ws.Cells(Cells.Rows.Count, "A").End(xlUp).Row

    If lr > 1 Then

        Set rng = ws.Range("E2:E" & lr)

        For Each cell In rng
            lr1 = ws1.Cells(Cells.Rows.Count, "A").End(xlUp).Row + 1

            If InStr(1, cell.Value, "open", vbTextCompare) > 0 Then cell.Value = "Open"
            If InStr(1, cell.Value, "Solved", vbTextCompare) Or InStr(1, cell.Value, "closed", vbTextCompare) > 0 Then
                cell.EntireRow.Copy ws1.Range("A" & lr1)

                If r Is Nothing Then

                    Set r = cell
                Else
                    Set r = Union(cell, r)
                End If
            End If

        Next cell
         If Not r Is Nothing Then r.EntireRow.Delete
         
    End If

Application.ScreenUpdating = True
Application.DisplayAlerts = True
   

End Sub

Open in new window

0
 
AckeemKAuthor Commented:
I hid a worksheet but I needed the validation for the open macro to happen in the 'Import' tab, sorry for leaving that part out. After that, if it can clear all the highlights in the 'Current' tab (currently a macro in place to highlight changes that is not displayed in this file) and then do the move of closed and solved that would be perfect.
0
Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

 
Saurabh Singh TeotiaCommented:
Use this version of the code...

Sub changestatus()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim lr As Long
    Dim cell As Range, rng As Range
    Dim ws As Worksheet, lr1 As Long
    Dim r As Range, ws1 As Worksheet


    Set ws = Sheets("Current")
    Set ws1 = Sheets("Closed")
    lr = ws.Cells(Cells.Rows.Count, "A").End(xlUp).Row

    If lr > 1 Then

        Set rng = ws.Range("E2:E" & lr)

        For Each cell In rng
            lr1 = ws1.Cells(Cells.Rows.Count, "A").End(xlUp).Row + 1


            If InStr(1, cell.Value, "Solved", vbTextCompare) Or InStr(1, cell.Value, "closed", vbTextCompare) > 0 Then
                cell.EntireRow.Copy ws1.Range("A" & lr1)

                If r Is Nothing Then

                    Set r = cell
                Else
                    Set r = Union(cell, r)
                End If
            End If

        Next cell
        If Not r Is Nothing Then r.EntireRow.Delete

    End If

    Set ws = Sheets("Import")
    lr = ws.Cells(Cells.Rows.Count, "A").End(xlUp).Row

    If lr > 1 Then

        Set rng = ws.Range("E2:E" & lr)

        For Each cell In rng

            If InStr(1, cell.Value, "open", vbTextCompare) > 0 Then cell.Value = "Open"
        Next cell


    End If

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True


End Sub

Open in new window

0
 
AckeemKAuthor Commented:
What can I put in the macro to clear all contents in the 'Import' tab to be the last step?
0
 
Saurabh Singh TeotiaCommented:
You can add this line at the last...

ws.cells.clear
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

  • 4
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now