GA036872

New Member
Joined
Jul 8, 2022
Messages
13
Office Version
  1. 365
Platform
  1. Windows
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:

VBA Code:
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 :/

1658174623167.png


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.

Excel Formula:
=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:

Excel Formula:
=IF(ISNUMBER(F2),$I$15, " ")

In column H I've used the following:
Excel Formula:
=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].

1658174848099.png


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! :)
 

Attachments

  • 1658174564478.png
    1658174564478.png
    166 KB · Views: 4

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.
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.
Code:
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.
 
Upvote 0
My personal preference is to never work with entire rows/columns if you don't have to.
Also qualify your sheets.
Code:
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.
Code:
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.
Code:
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
So this
Code:
For a = Range("'Merge'!A" & Rows.Count).End(xlUp).Row To 2 Step -1
would become this
Code:
For a = lr To 2 Step - 1
and this
Code:
If Range("'Merge'!f" & a) = "destroy" Then
would become this
Code:
If sh1.Cells(a, 6).Value = "destroy" Then
and these 2 lines
Code:
Rows(a).Copy
Sheets("REJECT").Rows(Sheets("REJECT").Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial
I would change to
Code:
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
Code:
Rows(a).Delete
to this
Code:
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.
 
Upvote 0
Code:
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
Code:
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.
 
Upvote 0
Solution
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:

VBA Code:
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 :confused: , 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
 
Upvote 0
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
Code:
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
 
Upvote 0
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?:
VBA Code:
lc = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
. Sorry - I've been trying to work it out for ages 🤣

1658346325090.png


That's the last question - I promise

Thanks again for your help :)
 
Upvote 0
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
Code:
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
Code:
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.
 
Last edited:
Upvote 0
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! :biggrin: 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

VBA Code:
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 :)

1660916045436.png
 
Upvote 0

Forum statistics

Threads
1,213,564
Messages
6,114,334
Members
448,567
Latest member
Kuldeep90

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