How to keep cells and macro button in one position when rows are cut

[GA036872]

Hi everyone

So I posted in here a few weeks ago and someone wrote me an excellent VBA which cuts and pastes rows to different sheets depending on what's written in column F of my workbook. The code is as follows:

Sub sort_my_data()
'VBA written by SQUIDD from MrExcel.com
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual: Application.DisplayAlerts = False: Application.EnableEvents = False
For a = Range("'Merge'!A" & Rows.Count).End(xlUp).Row To 2 Step -1
    If Range("'Merge'!f" & a) = "destroy" Then
        Rows(a).Copy
        Sheets("REJECT").Rows(Sheets("REJECT").Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial
        Rows(a).Delete
    End If
    If Range("'Merge'!f" & a) = "-" Then
        Rows(a).Copy
        Sheets("send").Rows(Sheets("send").Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial
        Rows(a).Delete
    End If
Next a
For Each ws In ActiveWorkbook.Worksheets
    ws.Columns.AutoFit
    ws.Rows.AutoFit
Next
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic: Application.DisplayAlerts = True: Application.EnableEvents = True
End Sub

Since then, I have added some more data to the workbook. For this reason, I have run into a few more problems: when I run the VBA, it cuts and pastes the rows as desired; however, this also means that it cuts cells I14, I15, I17, and I18 as a result. It also moves the macro button and the image. Before, there was nothing in these cells so it didn't matter. However, as they now contain data that I need - it's important that they stay in the same position when the VBA runs. The same applies to the macro button and the image - I need these to stay in the same place: if these cells move, the formulas posted below stop working :/

Is there a way of having the VBA run without those cells being cut? Cell I15 contains a drop down list using data validation from the Cycles sheet. I18 includes an XLOOKUP from another workbook.

=XLOOKUP(I15,Cycles.xlsx!$C$4:$C$40, Cycles.xlsx!$D$4:$D$40, " ")

I only want values in column G and H to appear if column F contains an amount, so I've used the following If Formula:

=IF(ISNUMBER(F2),$I$15, " ")

In column H I've used the following:

=IF(ISNUMBER(F2), $I$18, " ")

Another thing I want to change is the way columns G and H on the Send and Reject tabs look after the VBA has run. As columns G and H will only return values if cells in column F on the Merge sheet have an amount in - blank cells are being copied onto the Send and Reject tab and they always end up looking like this: [please note that I've pasted a shape over some columns for data protection purposes].

Is there a way to prevent the width of columns G and H on the Send and Reject tabs from getting so small - it looks really out of place.

Thanks for all your help!

 

[jolivanes]

You have a whole book full with questions. Good to see.
However, lets tackle one problem at the time for now.
For all shapes on your sheet that need to stay put.
Right click on the shape, select "Format Control" or "Size and Properties", select "Properties", select "Don't move or size with cells.". Click on OK
Or use this macro.

Sub Stay_Put()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
With shp
    .Placement = xlFreeFloating
End With
Next shp
End Sub

See if that does the trick.

As far as the rest of the questions go, I'll have a look because I think I would attack it differently.

 

[jolivanes]

My personal preference is to never work with entire rows/columns if you don't have to.
Also qualify your sheets.

Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet    '<----- change sh1, sh2 and sh3 to meaningful names.
Set sh1 = Worksheets("Merge")
Set sh2 = Worksheets("REJECT")
Set sh3 = Worksheets("send")

It looks like you don't need to go past Column H for copying and deleting.
Following will set the last Column used in the top row. In your case this looks to be Column H.

Dim lc As Long, lr As Long
lc = sh1.Cells(1, Columns.Count).End(xlToLeft).Column

Might as well set the last row for column A also.

lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row

So this

For a = Range("'Merge'!A" & Rows.Count).End(xlUp).Row To 2 Step -1

would become this

For a = lr To 2 Step - 1

and this

If Range("'Merge'!f" & a) = "destroy" Then

would become this

If sh1.Cells(a, 6).Value = "destroy" Then

and these 2 lines

Rows(a).Copy
Sheets("REJECT").Rows(Sheets("REJECT").Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial

I would change to

sh2.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, lc).Value = sh1.Cells(a, 1).Resize(, lc).Value

If you notice, this will only copy from Column A to Column H, not the whole row.
Change this

Rows(a).Delete

to this

sh1.Cells(a, 1).Resize(, lc).Delete Shift:=xlUp

Also, deletes only the cells of the first column to the last used column (=lc)
Same goes for the 2nd part of your code.
See if you can implement this. If not, let us know how far you got.
In the meantime, later on when I have some time, I'll have a look.
Looks like you could use Select Case or AutoFilter to your advantage.

 

[jolivanes]

Sub Try_So()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet    '<----- change sh1, sh2 and sh3 to meaningful names.
Dim lc As Long, lr As Long, i As Long
Set sh1 = Worksheets("Merge")
Set sh2 = Worksheets("Reject")
Set sh3 = Worksheets("Send")
lc = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
    For i = lr To 2 Step -1
        If sh1.Cells(i, 6).Value = "destroy" Then
            sh2.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, lc).Value = sh1.Cells(i, 1).Resize(, lc).Value
            sh1.Cells(i, 1).Resize(, lc).Delete Shift:=xlUp
                ElseIf sh1.Cells(i, 6).Value = "-" Then
            sh3.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, lc).Value = sh1.Cells(i, 1).Resize(, lc).Value
            sh1.Cells(i, 1).Resize(, lc).Delete Shift:=xlUp
        End If
    Next i
Application.ScreenUpdating = True
End Sub

or

Sub With_Select_Case()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet    '<----- change sh1, sh2 and sh3 to meaningful names.
Dim lc As Long, lr As Long, i As Long
Set sh1 = Worksheets("Merge")
Set sh2 = Worksheets("Reject")
Set sh3 = Worksheets("Send")
lc = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
    For i = lr To 2 Step -1
        Select Case Cells(i, 6).Value
            Case Is = "destroy"
                sh2.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, lc).Value = sh1.Cells(i, 1).Resize(, lc).Value
                sh1.Cells(i, 1).Resize(, lc).Delete Shift:=xlUp
            Case Is = "-"
                sh3.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, lc).Value = sh1.Cells(i, 1).Resize(, lc).Value
                sh1.Cells(i, 1).Resize(, lc).Delete Shift:=xlUp
        End Select
    Next i
Application.ScreenUpdating = True
End Sub

2 Pieces of code, not to confuse you but for you to go through it and decide which will be easier to adapt/change.

 

[GA036872]

Hi

Thanks so much for your help!

I've made two copies of my workbook and tried out each of the codes: they both work really well! Anything past the H column isn't moving when the macro is run which is brilliant!
The image and macro button isn't moving now that I've inserted the following on the Merge sheet as suggested:

Sub Stay_Put()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
With shp
    .Placement = xlFreeFloating
End With
Next shp
End Sub

onto the Merge Sheet]

I do have one question - and sorry if this seems daft: as both codes give the same result, would you recommend using one over the other or should I just use whichever one I find easier to understand - as the second uses Select_Case whereas the first one doesn't. As I'm new to this, I'm not sure if one has benefit over the other.

One thing I have noticed is the workbook does seems to be freezing a lot more now , but this probably has nothing to do with the VBA: I'm guessing it's because I have two XLOOKUPs and some If formulas and Excel sometimes can't handle it all at once.

There were a few things I forgot to add to my first post... how would I make it so that columns G and H on the Send and Destroy tabs do not auto adjust but the rest of the columns do? And how do I make it so that the VBA still runs regardless of the case of the text in column F: one of my colleagues likes to input "DESTROY" rather than "destroy" as it makes it easier for him to read; however, each time he does this, I have to use ctrl + H to replace all values with the lower case so that it can be recognised by the VBA. I just feel it's an extra step that could be avoided.

Sorry for the long post. Thanks again - your help is much appreciated!

Gerard

 

[jolivanes]

As far as which macro to use, keep both somewhere safe (!!!!!) for possible future use.
You can keep both in the same Module but comment one out (Put apostrophes in front of each line) so you know where it is.
With your Module open click on the help button and type:
Comment Block and Uncomment Block Commands
As I mentioned before, whichever one looks to be the easiest to change if needed should be the one you want to work with.
The "Select Case" has several advantages as far as flexibility goes in my opinion.
This should set the ColumnWidths to AutoFit except Columns G and H

Sub With_Select_Case()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet    '<----- change sh1, sh2 and sh3 to meaningful names.
Dim lc As Long, lc2 As Long, lr As Long, i As Long, k As Long
Dim shArr
Set sh1 = Worksheets("Merge")
Set sh2 = Worksheets("Reject")
Set sh3 = Worksheets("Send")
shArr = Array("Reject", "Send")    '<---- Change sheet names as required
lc = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
    For i = lr To 2 Step -1
        Select Case Cells(i, 6).Value
            Case Is = "destroy"
                sh2.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, lc).Value = sh1.Cells(i, 1).Resize(, lc).Value
                sh1.Cells(i, 1).Resize(, lc).Delete Shift:=xlUp
            Case Is = "-"
                sh3.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, lc).Value = sh1.Cells(i, 1).Resize(, lc).Value
                sh1.Cells(i, 1).Resize(, lc).Delete Shift:=xlUp
        End Select
    Next i
For k = LBound(shArr) To UBound(shArr)
With Sheets(shArr(k))
    lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
    .Range("A:F, I:" & Split(.Cells(1, lc).Address, "$")(1)).EntireColumn.AutoFit
End With
Next k
Application.ScreenUpdating = True
End Sub

 

[GA036872]

Hi again

So I tried this but it's still auto-fitting the columns on the "Send" and "Reject" tab so they're only 0.81 pixels wide - I'm guessing this is because there's nothing in those cells when they're copied over. As the purpose of this workbook is to do a mail merge from the "Merge" tab, I've thought about it and realised that I only need to cut and paste columns A to F onto the "Send" and "Reject" tab. Am I right in saying that if I do this, columns G and H on "Send" and "Reject" should stay at the width I set them to before running the Macro?

I'm guessing I would alter this part to do this?:

lc = sh1.Cells(1, Columns.Count).End(xlToLeft).Column

. Sorry - I've been trying to work it out for ages

That's the last question - I promise

Thanks again for your help

 

[jolivanes]

That part of the code is not changing the width of Columns G and H. It set all Columns in the used part of Row1 to AutoFit with the exception of these two Columns.
So changing the last used column (lc) is not going to do anything.
Delete this part of the code from Post #6

For k = LBound(shArr) To UBound(shArr)
With Sheets(shArr(k))
    lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
    .Range("A:F, I:" & Split(.Cells(1, lc).Address, "$")(1)).EntireColumn.AutoFit
End With
Next k

And replace with

For k = LBound(shArr) To UBound(shArr)
With Sheets(shArr(k))
    lc2 = .Cells(1, .Columns.Count).End(xlToLeft).Column
    .Range("G:H").ColumnWidth = 8.43    '<---- change to desired width
    .Range("A:F, I:" & Split(.Cells(1, lc2).Address, "$")(1)).EntireColumn.AutoFit
End With
Next k

Re: Am I right in saying that if I do this, columns G and H on "Send" and "Reject" should stay at the width I set them to before running the Macro? No
As mentioned above, the settings of the column widths is based on the last used cell in row 1

If all of this needs to be reworked, you'll have to let us know the constraints.

 

[GA036872]

Hi @jolivanes

I've been using your code for a month now and it works great! There are just a few changes I want to make but don't know how. You've stated that the width of columns G and H are changing when the rows are cut and pasted because it's based on the width of the last row, so if we wanted to make the following changes would it mean we'd have to stop using the last cell rule?? :

Firstly - how would we make it so that the Macro only cuts and pastes columns A to F? We don't require columns G and H to be pasted onto the "Send" and "Reject" tabs. We only need columns G and H for a mail merge and we only use the Merge tab for that.

Secondly - how do we make it so that columns A to G on the merge tab auto-adjust when populated by text from the XLOOKUP? The rows and columns on the Send and Reject tab do this when the macro is run. Would we need a separate macro for this as the current one is done via a button? Furthermore, would this slow the sheet down? At the moment - the code runs really fast and has never crashed since using it! Our only concern is that us wanting to make changes will slow it down.

If it's not realistic to have columns A to G on the merge tab auto-adjust when populated by text from the XLOOKUP, how would we make it so that they auto-adjust on the merge tab -- like they do on the "Send" and "Reject" tab -- after the macro is run?

This is the VBA you wrote and that we are using at the moment

Sub With_Select_Case()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet    '<----- change sh1, sh2 and sh3 to meaningful names.
Dim lc As Long, lc2 As Long, lr As Long, i As Long, k As Long
Dim shArr
Set sh1 = Worksheets("Merge")
Set sh2 = Worksheets("Reject")
Set sh3 = Worksheets("Send")
shArr = Array("Reject", "Send")    '<---- Change sheet names as required
lc = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
    For i = lr To 2 Step -1
        Select Case Cells(i, 6).Value
            Case Is = "destroy"
                sh2.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, lc).Value = sh1.Cells(i, 1).Resize(, lc).Value
                sh1.Cells(i, 1).Resize(, lc).Delete Shift:=xlUp
            Case Is = "DESTROY"
                sh2.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, lc).Value = sh1.Cells(i, 1).Resize(, lc).Value
                sh1.Cells(i, 1).Resize(, lc).Delete Shift:=xlUp
            Case Is = "-"
                sh3.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, lc).Value = sh1.Cells(i, 1).Resize(, lc).Value
                sh1.Cells(i, 1).Resize(, lc).Delete Shift:=xlUp
        End Select
    Next i
For k = LBound(shArr) To UBound(shArr)
With Sheets(shArr(k))
    lc2 = .Cells(1, .Columns.Count).End(xlToLeft).Column
    .Range("G:H").ColumnWidth = 20#      '<---- change to desired width
    .Range("A:F, I:" & Split(.Cells(1, lc2).Address, "$")(1)).EntireColumn.AutoFit
End With
Next k
Application.ScreenUpdating = True
End Sub

Hope this makes sense and thank you for all your help so far