VBA for moving row to another sheet

torz · Feb 21, 2015

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

tlowry · Feb 21, 2015

I think I understand what you wanted, however I got lost in your code. I tried to recreate the logic with simpler code. Some thoughts on this KIS model for coding.

Target, as passed as an argument, is a range of cells. I think you want to run this only if one cell is changed.

Code:

Set TargetCell = Target.Cells(1, 1)             ' check just one cell?

I’m not a fan of setting up variables to point to objects. It seems to me to just add another layer to look at. I recommend using the “with” approach:

Code:

[FONT=microsoft sans serif]With Worksheets("Reporting Sheet")[/FONT]

Instead of:

Code:

dim sht
Set sht = Worksheets("Reporting Sheet") 
With sht

Compound if statements give me a headache. I substituted a easier to read (for me anyway) Select Case logic

Code:

Select Case TargetCell.Value

When code is repeated, substitute a separate routine

Code:

FixWS "Outstanding - Customer Contact", TargetCell

With all that, here is some code that does what I think you wanted

Create a test excel document
Put this code into the module for the sheet in which the column 15 cell changes
Test and Test
Post results

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lRow As Long
    Dim i As Integer
    Dim TargetCell
    Set TargetCell = Target.Cells(1, 1)             ' check just one cell?
    If TargetCell.Column <> 15 Then Exit Sub
    Select Case TargetCell.Value
        Case "Remediation Complete"
            With Worksheets("Reporting Sheet")
                lRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                For i = 1 To 13
                    .Cells(lRow, i).Value = TargetCell.Offset(TargetCell.Row, i - 15).Value
                Next i
            End With
        Case "O2A iTam", "Tibco iTam", "Kenan iTam", "Other iTam", "Disconnect Inprogress"
            FixWS "Outstanding - iTams", TargetCell
        Case "Customer Contact"
            FixWS "Outstanding - Customer Contact", TargetCell
        Case "Open Copy"
            FixWS "Outstanding - Open Copy Order", TargetCell
        Case Else
           '  "Unknown value: " & TargetCell.Value
    End Select
End Sub
Sub FixWS(sht, tc)
    Dim iRow, iHeader
    With Sheets(sht)
        iRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        If Application.WorksheetFunction.CountA(.Columns("A")) = 0 Then iRow = 1
        tc.EntireRow.Copy Destination:=.Range("A" & iRow)
        tc.EntireRow.Delete
    End With
End Sub

torz · Feb 21, 2015

Hey mate,

Thanks heaps for giving it a shot!

100% correct, this is so much easier to read than previous... but we have ended up in a worse place than before. it now changes the number in the person column as well.

So here is a snapshot of the sample sheet (we'll call it the working sheet)

RESOURCE_NAME REMEDIATION_DATE account OCC TDU CR EOFY UCD TDU RR EOFY PA REMEDIATION_NOTES StartDate Remediation_Status EOFY Months_until_EOFY NotifyMeOn
Person2 13/12/2012 2 $5.00 11 $0.00 $0.00 asdfadfg asdfadfg 2/02/2012 5
Person3 14/12/2012 3 $3.00 11 $0.00 $0.00 asdfadfg asdfadfg 2/02/2012 5
Person4 15/12/2012 4 $1.00 11 $0.00 $0.00 asdfadfg asdfadfg 2/02/2012 5
Person5 16/12/2012 5 $3.00 11 $0.00 $0.00 asdfadfg asdfadfg 2/02/2012 5
Person6 17/12/2012 6 $43.00 11 $0.00 $0.00 asdfadfg asdfadfg 2/02/2012 5
Person7 18/12/2012 7 $4.00 11 $0.00 $0.00 asdfadfg asdfadfg 2/02/2012 5

<tbody>
</tbody>

So I have pasted the code you had into this sheet & when you change the Remediation status to the completed status it does not delete the row from the working sheet & when it copies the data to the reporting sheet this is the output

RESOURCE_NAME REMEDIATION_DATE account OCC TDU CR EOFY UCD TDU2 RR EOFY3 PA REMEDIATION_NOTES
Person4 15/12/2012 4 $1.00 11 $0.00 $0.00 asdfadfg asdfadfg
Person6 17/12/2012 6 $43.00 11 $0.00 $0.00 asdfadfg asdfadfg
Person4 15/12/2012 4 $1.00 11 $0.00 $0.00 asdfadfg asdfadfg

<colgroup><col><col><col><col><col><col><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>

So I've highlighted the rows so you know which row I said was completed.
I did Person2 twice and Person 3 once.

So when it is copied to the new sheet it is changing the PersonX number and it is also changing the account number which seems to be doubling the actual number from the working sheet, the $ figures are incorrect as well...

On a positive note, it still only copies the required columns over and leaves the ones I don't want in the reporting sheet out

torz · Feb 21, 2015

Ahhh I think I see what its doing, I just still don't know why... It is coping the wrong row to the reporting sheet. So when I said Person2 is complete it copies the details from 2 rows below (Person4 Details) & same for Person3 except instead of 2 rows down it copies the details from 3 rows below the active row.

Smitty · Feb 21, 2015

Welcome to the Board!

Instead of copying the complete items to a new sheet, why not just use a pivot table to summarize that information?

torz · Feb 21, 2015

Smitty said:
Welcome to the Board!

Instead of copying the complete items to a new sheet, why not just use a pivot table to summarize that information?

That was my original plan, but they don't want it like that for some reason, I find it so much easier to work with personally but maybe that's just me...

Smitty · Feb 21, 2015

torz said:
That was my original plan, but they don't want it like that for some reason, I find it so much easier to work with personally but maybe that's just me...

It's not just you, but Pivot Tables are often misunderstood. If you have Excel 2010+ I'd suggest building a sample using some Slicers just to show how powerful they can be.

tlowry · Feb 21, 2015

Now back into the "Way back" machine.

1. The reason it started in the second row is due to the fact that I didn't have any headers in mine.
2. The reason it didn't delete the row is that I left out a delete row command.
3. The fix for not "moving" cells was due to the non use of the "ActiveSheet"

So, give this a try and post the results

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lRow As Long
    Dim i As Integer
    Dim TargetCell
    Set TargetCell = Target.Cells(1, 1)             ' check just one cell?
    If TargetCell.Column <> 15 Then Exit Sub
    Select Case TargetCell.Value
        Case "Remediation Complete"
            With Worksheets("Reporting Sheet")
                lRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
               [COLOR=#008000] '-------------------------------------------
                ' account for no row (including header)
                If Application.WorksheetFunction.CountA(.Columns("A")) = 0 Then lRow = 1[/COLOR]
                For i = 1 To 13
                ' fix for correct worksheet
                    .Cells(lRow, i).Value = [COLOR=#0000cd]ActiveSheet[/COLOR].Cells(TargetCell.Row, i).Value
                Next i
            End With
        [COLOR=#a52a2a]'------------------------------------
        ' delete the row just processed
        ActiveSheet.Rows(TargetCell.Row).EntireRow.Delete[/COLOR]
        Case "O2A iTam", "Tibco iTam", "Kenan iTam", "Other iTam", "Disconnect Inprogress"
            FixWS "Outstanding - iTams", TargetCell
        Case "Customer Contact"
            FixWS "Outstanding - Customer Contact", TargetCell
        Case "Open Copy"
            FixWS "Outstanding - Open Copy Order", TargetCell
        Case Else
           '  "Unknown value: " & TargetCell.Value
    End Select
End Sub
Sub FixWS(sht, tc)
    Dim iRow
    With Sheets(sht)
        iRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        If Application.WorksheetFunction.CountA(.Columns("A")) = 0 Then iRow = 1
        tc.EntireRow.Copy Destination:=.Range("A" & iRow)
    End With
    ActiveSheet.Rows(tc.Row).EntireRow.Delete
End Sub

rollis13 · Feb 21, 2015

Cross-post: Help with VBA for moving row to new sheet

torz · Feb 21, 2015

tlowry said:

Now back into the "Way back" machine.

1. The reason it started in the second row is due to the fact that I didn't have any headers in mine.
2. The reason it didn't delete the row is that I left out a delete row command.
3. The fix for not "moving" cells was due to the non use of the "ActiveSheet"

So, give this a try and post the results

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lRow As Long
    Dim i As Integer
    Dim TargetCell
    Set TargetCell = Target.Cells(1, 1)             ' check just one cell?
    If TargetCell.Column <> 15 Then Exit Sub
    Select Case TargetCell.Value
        Case "Remediation Complete"
            With Worksheets("Reporting Sheet")
                lRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
               [COLOR=#008000] '-------------------------------------------
                ' account for no row (including header)
                If Application.WorksheetFunction.CountA(.Columns("A")) = 0 Then lRow = 1[/COLOR]
                For i = 1 To 13
                ' fix for correct worksheet
                    .Cells(lRow, i).Value = [COLOR=#0000cd]ActiveSheet[/COLOR].Cells(TargetCell.Row, i).Value
                Next i
            End With
        [COLOR=#a52a2a]'------------------------------------
        ' delete the row just processed
        ActiveSheet.Rows(TargetCell.Row).EntireRow.Delete[/COLOR]
        Case "O2A iTam", "Tibco iTam", "Kenan iTam", "Other iTam", "Disconnect Inprogress"
            FixWS "Outstanding - iTams", TargetCell
        Case "Customer Contact"
            FixWS "Outstanding - Customer Contact", TargetCell
        Case "Open Copy"
            FixWS "Outstanding - Open Copy Order", TargetCell
        Case Else
           '  "Unknown value: " & TargetCell.Value
    End Select
End Sub
Sub FixWS(sht, tc)
    Dim iRow
    With Sheets(sht)
        iRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        If Application.WorksheetFunction.CountA(.Columns("A")) = 0 Then iRow = 1
        tc.EntireRow.Copy Destination:=.Range("A" & iRow)
    End With
    ActiveSheet.Rows(tc.Row).EntireRow.Delete
End Sub

thanks for all the help lowry! still does the same thing, does not remove the active row after changing the status
and that is the Person2 one again so all the figures are being copied from row #4 instead of row #2

RESOURCE_NAME REMEDIATION_DATE account OCC TDU CR EOFY UCD TDU RR EOFY PA REMEDIATION_NOTES
Person5 16/12/2012 5 $3.00 11 $0.00 $0.00 asdfadfg asdfadfg

<colgroup><col><col><col><col><col><col><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>

VBA for moving row to another sheet

torz

New Member

Excel Facts

tlowry

Well-known Member

torz

New Member

torz

New Member

Smitty

Legend

torz

New Member

Smitty

Legend

tlowry

Well-known Member

rollis13

Well-known Member

torz

New Member

Similar threads

Forum statistics

Share this page

RESOURCE_NAME	REMEDIATION_DATE	account	OCC	TDU	CR	EOFY	UCD	TDU	RR	EOFY	PA	REMEDIATION_NOTES	StartDate	Remediation_Status	EOFY	Months_until_EOFY	NotifyMeOn
Person2	13/12/2012	2	$5.00	11	$0.00	$0.00					asdfadfg	asdfadfg			2/02/2012	5
Person3	14/12/2012	3	$3.00	11	$0.00	$0.00					asdfadfg	asdfadfg			2/02/2012	5
Person4	15/12/2012	4	$1.00	11	$0.00	$0.00					asdfadfg	asdfadfg			2/02/2012	5
Person5	16/12/2012	5	$3.00	11	$0.00	$0.00					asdfadfg	asdfadfg			2/02/2012	5
Person6	17/12/2012	6	$43.00	11	$0.00	$0.00					asdfadfg	asdfadfg			2/02/2012	5
Person7	18/12/2012	7	$4.00	11	$0.00	$0.00					asdfadfg	asdfadfg			2/02/2012	5

VBA for moving row to another sheet

New Member

Excel Facts

Well-known Member

New Member

New Member

Legend

New Member

Legend

Well-known Member

Well-known Member

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock