VBA multiple target.column

Kevo85

New Member
Joined
Feb 5, 2025
Messages
4
Office Version
  1. 365
I currently can make these formulas work independently, but I would like to combine them. If checkbox in column 15 is true or if cell in colum 16 is not empty, that the row will be moved after the last row.
Also if possible, how could I make that the rows are moved 10 rows after the last row, and that subsequent lowered rows will go after that one etc..

Formula 1:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim r As Long

If Target.CountLarge > 1 Then Exit Sub

If Target.Column <> 15 Then Exit Sub

If Target.Value = True Then
r = Target.Row
Application.EnableEvents = False
Rows(r).Cut
Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Rows(r).Delete
Application.EnableEvents = True
End If

End Sub

Formula 2:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim r As Long

If Target.CountLarge > 1 Then Exit Sub

If Target.Column <> 16 Then Exit Sub

If Target.Value <> " " Then
r = Target.Row
Application.EnableEvents = False
Rows(r).Cut
Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Rows(r).Delete
Application.EnableEvents = True
End If

End Sub

Thanks
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Welcome to the Board!

You need to combine them. Instead of telling it when to exit the sub, tell it when to do something.
Then you can combine those two code blocks like this:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)

Dim r As Long

If Target.CountLarge > 1 Then Exit Sub

'First Condition
If Target.Column = 15 Then
    If Target.Value = True Then
        r = Target.Row
        Application.EnableEvents = False
        Rows(r).Cut
        Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
        Rows(r).Delete
        Application.EnableEvents = True
    End If
End If

'Second condition
If Target.Column = 16 Then
    If Target.Value <> " " Then
        r = Target.Row
        Application.EnableEvents = False
        Rows(r).Cut
        Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
        Rows(r).Delete
        Application.EnableEvents = True
    End If
End If

End Sub
 
Upvote 0
Solution
Thank you! And would I do it to move the rows 10 rows after the last one? If I change the offset by 10, each newly row that is moved down goes 10 rows inbetween them, creating many empty rows. I would like that the first row that is moved down goes 10 rows after the last one, and all other moved rows will go under that one
 
Upvote 0
So you want it to move 10 rows after the last row the first time, and then under the last row each subsequent time?
If so, then you are probably going to need a way to distinguish (or capture) the FIRST move from the rest.

How we can do that might depends on the structure of your data (which you have not shown us).
Let me ask you these questions:
- what row does the first row of data start on?
- are there currently ANY blank rows of data in the middle of your data?
- if the answer to the question above is "No", for all data rows, can you tell us a column which will ALWAYS have an entry in it (column that is always populated for existing data rows)?
 
Upvote 0
I really appreciate your time and your help.
Yes you have it correct. Data would be approximately on max 100 rows. If moved rows could go to row 110 and subsenquent rows would go 111, 112, etc.

Data starts on row 4
no blank rows in the middle of the data
column A-B-C would always have data

Thank you
 
Upvote 0
OK, try this then:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)

Dim r As Long

If Target.CountLarge > 1 Then Exit Sub

'First Condition
If Target.Column = 15 Then
    If Target.Value = True Then
        r = Target.Row
        Application.EnableEvents = False
        Rows(r).Cut
'       Check to see if blank rows already inserted
        If Cells(1, "A").End(xlDown).Row = Cells(Rows.Count, "A").End(xlUp).Row Then
'           Insert 10 blank rows
            Cells(Rows.Count, "A").End(xlUp).Offset(10, 0).Select
        Else
'           Put after last row
            Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Select
        End If
        ActiveSheet.Paste
        Rows(r).Delete
        Application.EnableEvents = True
    End If
End If

'Second condition
If Target.Column = 16 Then
    If Target.Value <> " " Then
        r = Target.Row
        Application.EnableEvents = False
        Rows(r).Cut
'       Check to see if blank rows already inserted
        If Cells(1, "A").End(xlDown).Row = Cells(Rows.Count, "A").End(xlUp).Row Then
'           Insert 10 blank rows
            Cells(Rows.Count, "A").End(xlUp).Offset(10, 0).Select
        Else
'           Put after last row
            Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Select
        End If
        ActiveSheet.Paste
        Rows(r).Delete
        Application.EnableEvents = True
    End If
End If

End Sub
 
Upvote 0
Unfortunately, it doesn't work. But I found an easy workaround. I just entered in column A at row 100 "Completed files" and since there is data on column A at that row, it is recognized as the last row and all subsequent rows that are moved down go under that row.
 
Upvote 0
Unfortunately, it doesn't work. But I found an easy workaround. I just entered in column A at row 100 "Completed files" and since there is data on column A at that row, it is recognized as the last row and all subsequent rows that are moved down go under that row.
It worked in my testing.
If it didn't work for you, probably means one of two things:
1. There were blanks somewhere in column A in the middle of your data,
2. You may have had extra items below your last row of data in column A, or cells that were not really blank (maybe a space or something in them).

Anyway, whatever the cause may be with your data, I am glad you found a workaround that worked for you.
 
Upvote 0

Forum statistics

Threads
1,226,453
Messages
6,191,136
Members
453,642
Latest member
jefals

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