VBA for moving row to another sheet

T

torz

New Member
Joined
Sep 18, 2011
Messages
18
Hey guys,

I have absolutely no idea what I have mixed up here...

I tried a bunch of different sample codes and some seems to overwrite the last row instead of going to the next blank row (only every now and then, not every time).

But the current code in the sample seems to be working to a point... It copies the entire rows to the new sheets fine, have not seen it overwrite anything at all yet.

The issue is when it copies to the remediation complete sheet the account number seems to get an additional value added to it from somewhere. Eg

account number 1 --> remediation sheet the account number changes to be 3

please see the sample sheet (excel 2010) will make it a lot easier than trying to explain. :P (must be having a total spastic day, cant seem to upload the sample so code below)


Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

Dim sht As Worksheet
Dim nxtRow As Integer
Dim lRow As Long


    'Determine if change was to Column C (3)
    If Target.Column = 15 Then
    'If Yes, Determine if cell = "Remediation Complete"
        If Target.Value = "Remediation Complete" Then
            Set sht = Worksheets("Reporting Sheet")
            lRow = sht.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Row
            With sht
                .Cells(lRow, 1).Value = Target.Cells.Offset(Target.Row, -14).Value
                .Cells(lRow, 2).Value = Target.Cells.Offset(Target.Row, -13).Value
                .Cells(lRow, 3).Value = Target.Cells.Offset(Target.Row, -12).Value
                .Cells(lRow, 4).Value = Target.Cells.Offset(Target.Row, -11).Value
                .Cells(lRow, 5).Value = Target.Cells.Offset(Target.Row, -10).Value
                .Cells(lRow, 6).Value = Target.Cells.Offset(Target.Row, -9).Value
                .Cells(lRow, 7).Value = Target.Cells.Offset(Target.Row, -8).Value
                .Cells(lRow, 8).Value = Target.Cells.Offset(Target.Row, -7).Value
                .Cells(lRow, 9).Value = Target.Cells.Offset(Target.Row, -6).Value
                .Cells(lRow, 10).Value = Target.Cells.Offset(Target.Row, -5).Value
                .Cells(lRow, 11).Value = Target.Cells.Offset(Target.Row, -4).Value
                .Cells(lRow, 12).Value = Target.Cells.Offset(Target.Row, -3).Value
                .Cells(lRow, 13).Value = Target.Cells.Offset(Target.Row, -2).Value
            End With
            'Delete changed row now that account has been remediated & moved to the Reporting Sheet
            Target.EntireRow.Delete
        ElseIf Target.Value = "O2A iTam" Or Target.Value = "Tibco iTam" Or Target.Value = "Kenan iTam" Or Target.Value = "Other iTam" Or Target.Value = "Disconnect Inprogress" Then
            'If Yes, find next empty row in Reporting Sheet
            Set sht = Worksheets("Outstanding - iTams")
            lRow = sht.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Row
            'Copy changed row and paste into Reporting Sheet
            Target.EntireRow.Copy Destination:=sht.Range("A" & lRow)
            'Delete changed row now that account has been remediated & moved to the Reporting Sheet
            Target.EntireRow.Delete
        ElseIf Target.Value = "Customer Contact" Then
            'If Yes, find next empty row in Reporting Sheet
            Set sht = Worksheets("Outstanding - Customer Contact")
            lRow = sht.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Row
            'Copy changed row and paste into Reporting Sheet
            Target.EntireRow.Copy Destination:=sht.Range("A" & lRow)
            'Delete changed row now that account has been remediated & moved to the Reporting Sheet
            Target.EntireRow.Delete
        ElseIf Target.Value = "Open Copy" Then
            'If Yes, find next empty row in Reporting Sheet
            Set sht = Worksheets("Outstanding - Open Copy Order")
            lRow = sht.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Row
            'Copy changed row and paste into Reporting Sheet
            Target.EntireRow.Copy Destination:=sht.Range("A" & lRow)
            'Delete changed row now that account has been remediated & moved to the Reporting Sheet
            Target.EntireRow.Delete
        End If
    End If
    
End Sub
 
Sort by date Sort by votes
Hi, not fully tested but see if this code does what you want:

Place following in your sheets code page:

Code: 
Option Base 1
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim m As Variant, wsarr As Variant
    Dim arr As Variant
    
    'cell keywords
    arr = Array("O2A iTam", "Tibco iTam", "Kenan iTam", "Other iTam", "Disconnect Inprogress", _
                "Remediation Complete", "Customer Contact", "Open Copy")
 
    'destination sheets
    wsarr = Array("Outstanding - iTams", "Reporting Sheet", _
                  "Outstanding - Customer Contact", "Outstanding - Open Copy Order")
 
    'Determine if change was to Column O (15)
    On Error Resume Next
    If Target.Column = 15 And Target.Row > 1 Then
        'get index to keyword in arr
        m = Application.Match(Target.Value, arr, False)
        If Not IsError(m) Then
          If m < 6 Then m = 1
          If m > 5 Then m = m - 4
            'move record to destination sheet
            MoveRecord Target:=Target, Destination:=Worksheets(wsarr(m))
        Else
            'no matches report error
            MsgBox Target.Value & Chr(10) & "Destination Sheet Does Not Exits", 16, "Not Found"
        End If
    End If
        
End Sub

Note Option Base 1 - it is important that this is placed at very top of the code page.


Place following either in standard module or sheets code page.

Code: 
Sub MoveRecord(ByVal Target As Range, ByVal Destination As Object)
    Dim lRow As Long
    Dim data As Variant
 
    On Error GoTo myerror
    
    'lRow = Destination.Cells(Rows.Count, 1).End(xlUp).Row + 1
    
    lRow = NewRow(sh:=Destination)
 
    If Destination.Name = "Reporting Sheet" Then
        'copy defined range to desitnation sheet
        data = Target.Parent.Range("A" & Target.Row & ":M" & Target.Row).Value
        Destination.Range("A" & lRow).Resize(1, UBound(data, 2)).Value = data
    Else
        'Copy row and paste into Destination Sheet
        Target.EntireRow.Copy Destination.Range("A" & lRow)
    End If
    'Delete changed row now that account has been remediated & moved to destination sheet
     Target.EntireRow.Delete
     'report complete
    MsgBox "Record Transferred To: " & Destination.Name, 48, "Record Transferred"
    
myerror:
    'report if something went wrong
   If Err > 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub


Function NewRow(ByVal sh As Object) As Long
    'stock code
    On Error Resume Next
     NewRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row + 1
    On Error GoTo 0
End Function

I have included a stock function "NewRow" as noted your comment that records sometimes are overwritten - this function should hopefully, prove more reliable. I have though, left previous method if prefer to use that.

Hope helpful

Dave
 
Upvote 0

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
dmt32 said:
Hi, not fully tested but see if this code does what you want:

Place following in your sheets code page:

Code: 
Option Base 1
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim m As Variant, wsarr As Variant
    Dim arr As Variant
    
    'cell keywords
    arr = Array("O2A iTam", "Tibco iTam", "Kenan iTam", "Other iTam", "Disconnect Inprogress", _
                "Remediation Complete", "Customer Contact", "Open Copy")
 
    'destination sheets
    wsarr = Array("Outstanding - iTams", "Reporting Sheet", _
                  "Outstanding - Customer Contact", "Outstanding - Open Copy Order")
 
    'Determine if change was to Column O (15)
    On Error Resume Next
    If Target.Column = 15 And Target.Row > 1 Then
        'get index to keyword in arr
        m = Application.Match(Target.Value, arr, False)
        If Not IsError(m) Then
          If m < 6 Then m = 1
          If m > 5 Then m = m - 4
            'move record to destination sheet
            MoveRecord Target:=Target, Destination:=Worksheets(wsarr(m))
        Else
            'no matches report error
            MsgBox Target.Value & Chr(10) & "Destination Sheet Does Not Exits", 16, "Not Found"
        End If
    End If
        
End Sub

Note Option Base 1 - it is important that this is placed at very top of the code page.


Place following either in standard module or sheets code page.

Code: 
Sub MoveRecord(ByVal Target As Range, ByVal Destination As Object)
    Dim lRow As Long
    Dim data As Variant
 
    On Error GoTo myerror
    
    'lRow = Destination.Cells(Rows.Count, 1).End(xlUp).Row + 1
    
    lRow = NewRow(sh:=Destination)
 
    If Destination.Name = "Reporting Sheet" Then
        'copy defined range to desitnation sheet
        data = Target.Parent.Range("A" & Target.Row & ":M" & Target.Row).Value
        Destination.Range("A" & lRow).Resize(1, UBound(data, 2)).Value = data
    Else
        'Copy row and paste into Destination Sheet
        Target.EntireRow.Copy Destination.Range("A" & lRow)
    End If
    'Delete changed row now that account has been remediated & moved to destination sheet
     Target.EntireRow.Delete
     'report complete
    MsgBox "Record Transferred To: " & Destination.Name, 48, "Record Transferred"
    
myerror:
    'report if something went wrong
   If Err > 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub


Function NewRow(ByVal sh As Object) As Long
    'stock code
    On Error Resume Next
     NewRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row + 1
    On Error GoTo 0
End Function

I have included a stock function "NewRow" as noted your comment that records sometimes are overwritten - this function should hopefully, prove more reliable. I have though, left previous method if prefer to use that.

Hope helpful

Dave
Click to expand...


Thanks heaps Dave works an absolute treat!

Ill have to take a good look at it a bit later and figure it all out, just about to head to bed but had to give it a try beforehand :)


Thank you so much!! :) and to everyone else as well!!!
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question
Estimating Spreadsheet-Summing
Replies
1
Views
159
Peter_SSs
Peter_SSs
E
  • Solved
Summing Values
Replies
3
Views
235
LazyBug
LazyBug
A
  • Question
Moving Rows Up (Scroll) To Defined Row Number for Viewing
Replies
6
Views
220
Ark68
A
N
  • Solved
Copy/paste a row from within a loop, before that loop moves on to next cell
Replies
5
Views
255
Joe4
Joe4
P
  • Solved
Excel VBA, Vlookup to another sheet in same work book
Replies
6
Views
214
StephenCrump
S

Forum statistics

Threads
1,215,327
Messages
6,124,289
Members
449,149
Latest member
mwdbActuary

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top