I'm new to vba, and I've written the code below but can't figure out why it's not working.
Sub DataValidationDeleteWrongOrigin()
'
'Description: Goes through and deletes rows that are called out on the delete entry column.
'
'Dimension Worksheet
Dim DataValWs As Worksheet
Set DataValWs = Worksheets("Data Validation")
'Find the size of the table and store it as LastDataRow
Dim LastDataRow As Long
LastDataRow = DataValWs.Range("A5").End(xlDown).Row
'ThisRow will be the current row as the for loop goes through each row.
Dim ThisRow As Long
Dim DeleteRange As Range
Dim CurrentRow As Range
'Start the for loop from row 5
For ThisRow = 5 To LastDataRow
'Check the Delete Entry row to see if it says Yes, delete the row. Use DeleteRange to add cells to it and delete them all at the end (much _
faster than deleting them one at a time, and you don't have to re-find the size of the table after each row is deleted).
If Cells(ThisRow, 16) = "Yes" Then
If Not DeleteRange Is Nothing Then
Set CurrentRow = DataValWs.Rows(ThisRow)
Set DeleteRange = Union(CurrentRow, DeleteRange)
Else
Set DeleteRange = DataValWs.Cells(ThisRow, 16)
End If
End If
Next ThisRow
'DeleteRange.Select
DeleteRange.EntireRow.Delete
End Sub
Currently, the code gives me
Run-time error 1004 : Delete method of Range class failed.
The "DeleteRange.Select" that is commented out near the end of the code selects the correct range, so I know the range is being built accurately.
I want to be able to just drop all of the rows to be deleted off of the sheet at once --the number of rows to be deleted could get pretty high in this application, and I'd prefer it not take forever to run.
I've looked around online, and found a couple of solutions that involve going through the DeleteRange iteratively and deleting each row out of it, but that gives me the same problem of deleting rows one at a time. Is there a better way to handle this? Or, better yet, have I messed up in defining the DeleteRange?
Thank you!
Edit:
Did some testing with different sets of rows, and it turns out it has no problem deleting the rows if they're all adjacent to each other. Only results in the run time error if the rows have gaps between them...
I could replicate your problem only when there was an object at the side of the range (i.e. a ListObject )
Check the data in your worksheet and if that is the case use rDelete.Delete Shift:=xlUp
Assuming your DATA is located in the range A5:P# (where # is the last row of data) use this code.
Sub Delete_Rows()
Dim ws As Worksheet
Dim rDelete As Range
Dim rData As Range, rRow As Range, lRw As Long
Set ws = Worksheets("Data Validation")
With ws
lRw = .Range("A5").End(xlDown).Row
Set rData = Range(.Range("A5"), Range("P" & lRw)) 'adjust as required
End With
For Each rRow In rData.Rows
If rRow.Cells(16) = "Yes" Then
If rDelete Is Nothing Then
Set rDelete = rRow
Else
Set rDelete = Union(rDelete, rRow)
End If: End If: Next
rDelete.Delete Shift:=xlUp
End Sub
Add the "EntireRow" property to the line as follows:
Set DeleteRange = DataValWs.Cells(ThisRow, 16).EntireRow
Related
This question already has answers here:
Delete Column Loop VBA
(2 answers)
Closed 3 years ago.
I have a macro where I search for text in a row and if a column does not have my specified text it is deleted. Here is my code:
Private Sub Test()
Dim lColumn As Long
lColumn = ActiveSheet.Cells(2, Columns.Count).End(xlToLeft).Column
Dim i As Long
Dim myCell As Range
Dim myRange As Range
Set myRange = Worksheets("2019").Range(Cells(2, 1), Cells(2, lColumn))
For Each myCell In myRange
If Not myCell Like "*($'000s)*" And Not myCell Like "*Stmt Entry*" And Not myCell Like "*TCF*" And_
Not myCell Like "*Subtotal*" And Not myCell Like "*Hold*" Then
myCell.EntireColumn.Select
Selection.Delete
End If
Next
End Sub
My issue is that when I execute the macro it will only delete some of the columns but not the ones towards the end of the range. If I then run the macro again it will successfully delete all the columns I ask it to.
If I switch the macro to- let's say- make the cells bold instead of deleting them it works perfectly every time.
What am I missing?
Many thanks!
Despite everyone saying "just loop backwards" in this & linked posts, that's not what you want to do.
It's going to work, and then your next question will be "how can I speed up this loop".
The real solution is to stop what you're doing, and do things differently. Modifying a collection as you're iterating it is never a good idea.
Start with a helper function that can combine two ranges into one:
Private Function CombineRanges(ByVal source As Range, ByVal toCombine As Range) As Range
If source Is Nothing Then
'note: returns Nothing if toCombine is Nothing
Set CombineRanges = toCombine
Else
Set CombineRanges = Union(source, toCombine)
End If
End Function
Then declare a toDelete range and use this CombineRanges function to build ("select") a Range while you're iterating - note that this loop does not modify any cells anywhere:
Dim sheet As Worksheet
' todo: use sheet's codename instead if '2019' is in ThisWorkbook
Set sheet = ActiveWorkbook.Worksheets("2019")
Dim source As Range
' note: qualified .Cells member calls refer to same sheet as .Range call
Set source = sheet.Range(sheet.Cells(2, 1), sheet.Cells(2, lColumn))
Dim toDelete As Range
Dim cell As Range
For Each cell In source
'note: needed because comparing cell.Value with anything will throw error 13 "type mismatch" if cell contains a worksheet error value.
'alternatively, use cell.Text.
If Not IsError(cell.Value) Then
If Not cell.Value Like "*($'000s)*" _
And Not cell.Value Like "*Stmt Entry*" _
And Not cell.Value Like "*TCF*" _
And Not cell.Value Like "*Subtotal*" _
And Not cell.Value Like "*Hold*" _
Then
Set toDelete = CombineRanges(cell, toDelete)
End If
End If
Next
The last, final step is to delete the .EntireColumn of the toDelete range... if it isn't Nothing at that point:
If Not toDelete Is Nothing Then toDelete.EntireColumn.Delete
I have a workbook that includes duplicated headers and a page number that I want to remove via vba macro.
The below screenshot repeats itself throughout my workbook, I have tried to write a macro that finds the specific text and delete but causes the data to shift incorrectly and is wildly inefficient. The rows in between the headers are not always 3 so I can't have a macro that blindly deletes 5 rows every x rows. For clarity, I am trying to delete the bolded text while not losing the integrity of the unbolded data.
Is it possible to have a macro that goes over a specific range to delete the repeated headers and metadata depicted above?
Macro attempted to use from How to delete row based on cell value. Understandably changing the text for each header / metadata is not a reasonable solution and causes the data shift.
Sub DeleteRowsWithHyphen()
Dim rng As Range
For Each rng In Range("A2:A20") 'Range of values to loop through
If InStr(1, rng.Value, "Page 1 of 10") > 0 Then 'InStr returns an integer of the position, if above 0 - It contains the string
rng.Delete
End If
Next rng
End Sub
It looks like you can delete all rows that are not number in column. If so then try ..
Sub DeleteNonNumberRows()
Dim rng As Range, Cl As Range, DelRng As Range
LRow = Range("A" & Rows.Count).End(xlUp).Row
Set rng = Range("A1", "A" & LRow)
For Each Cl In rng
If IsNumeric(Cl) = False Or Cl = "" Then
If DelRng Is Nothing Then
Set DelRng = Cl
Else
Set DelRng = Union(DelRng, Cl)
End If
End If
Next
DelRng.EntireRow.Delete
End Sub
Note that rng is starting from A1. Change it as suitable.
I have made a simple macro assigned to a hotkey to select the current region and then remove the header row. The problem is that the ranges we work with are often full of blank cells which prevent the selector from capturing the entire table dependant on the activecell.
I thought about maybe simply creating a loop, offsetting the ActiveCell and trying again until it hits an illegal range, but I have a bad feeling about this approach.
Sub multieditSelect()
Dim tbl As Range
If ActiveCell.Value = "" Then
MsgBox "Select a cell with something in it, you bastard"
Exit Sub
End If
Call startNoUpdates
Set tbl = ActiveCell.CurrentRegion
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, _
tbl.Columns.Count).Select
Call endNoUpdates
Selection.Copy
End Sub
Is there a way to make this more reliable?
Edit: Let me add further complication/detail to this problem...
We work with a database and editing records en masse requires exporting them into excel, and the copy/pasting them back into the web interface, so it is common for us to be working with numerous tables of different size, using a worksheet like a notepad to store and modify them.
I want to create a sub that will select the current region irrespective of where it lies on the worksheet, quite possibly this is the third or fourth table to have been pasted onto the same sheet.
This makes going by the last column or last row too inflexible. CurrentRegion is ideal were it not for it's occasional failure to detect the table... so I suppose I need to build my own version of CurrentRegion that will overcome it's shortcomings.
Edit2: I've come up with a lazy solution.
Since these tables will always have a header, I'll just have the activecell offset up till it hits something, and hopefully that will be the header if an empty column is the starting point.
I think this will still be unreliable should there be a pocket of cells surrounded by empty cells in the middle of the table.
Sub multieditSelect2()
Dim tbl As Range
On Error GoTo errmsg
startNoUpdates
Do While ActiveCell.Value = ""
ActiveCell.Offset(-1, 0).Activate
Loop
startNoUpdates
Set tbl = ActiveCell.CurrentRegion
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, _
tbl.Columns.Count).Select
endNoUpdates
Selection.Copy
Exit Sub
errmsg:
endNoUpdates
errMsgBox = MsgBox("Couldn't find a table!", vbCritical, "Error!")
End Sub
Edit3: Here is an example of where my code calls down:
I would like it to be able to capture the table even in this scenario where a cell in the test region is the activecell... but how?
Additional to my comment, see if this helps improve your logic (see comments in code for more details):
Sub multieditSelect()
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Sheet1") 'use a variable for the sheet you want to use
Dim tbl As Range
Dim lRow As Long, lCol As Long
lRow = ws.Cells(Rows.Count, 1).End(xlUp).Row 'last row at column 1
lCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column 'last column at row 1
Set tbl = ws.Range(ws.Cells(2, l), ws.Cells(lRow, lCol)) 'Set the range starting at row 2, column 1, until last row, last col
Call endNoUpdates(tbl) 'pass your range as a parameter if you require this specific range in your other sub
tbl.Copy Destination:=tbl.Offset(0, 20) 'copy 20 columns to the right
'Alternative
ws.Range("W1").Resize(tbl.Rows.Count, tbl.Columns.Count).Value = tbl.Value 'copy values to specific range
End Sub
Sub endNoUpdates(tbl As Range)
'do something with this range, i.e.:
Debug.Print tbl.address
End Sub
New to VBA
I'm confused as to why I need to run my module twice to get it to update my cells. My code:
Option Explicit
Sub m_Range_End_Method()
Dim lRow As Long
Dim lCol As Long
Dim currentRow As Long
Dim i As Integer
Dim rng As Range
Set rng = ActiveCell
Range("B:B").Select
lRow = Cells(Rows.Count, 1).End(xlUp).Row
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
Sheets("MySheet").Select
' Loop Through Cells to set description in each cell
Do While rng.Value <> Empty
currentRow = ActiveCell.Row
If InStr(rng.Value, "PETROL") = 0 Then
Set rng = rng.Offset(1)
rng.Select
Else
Worksheets("MySheet").Cells(currentRow, 5) = "Shopping"
Worksheets("MySheet").Cells(currentRow, 6) = "Car"
Set rng = rng.Offset(1)
rng.Select
End If
Loop
End Sub
On the first run what happens in Excel 2016 is that Column B gets highlighted and that's it. I then have to press "Run" again in visual basics editor for it to then update all the entries at which point column B gets unselected. All I want to do is update the cells at the currentRow of a specified worksheet. I've been reading but have got myself into some confusion, someone said I should use the
Range("B:B").Select
statement and for some reason the spreadsheet update works but only if I run it twice. Without this Range command, for reasons I don't understand, the spreadsheet doesn't update - all that happens is that the box selection moves to entries with Petrol and stays there with the program running but not updating.
The aim of the program is to find in a sheet all occurrences of a word in column B, in this initial case that is PETROL (I'm going to expand to include many others). For that match on the same row I want it to update columns 5 and 6 with descriptions. The excel spreadsheet will have hundreds of rows of entries with varying descriptions in column B.
Any help would be much appreciated.
I guess you have to run it twice because the first time you run it, the ActiveCell could be anything, and your loop depends on it not being empty to start with, but after the first run you have selected column B (and other things)...
Read this previous answer on avoiding the use of Select and Activate, it will make your code more robust: How to avoid using Select in Excel VBA macros
Revised Code
See the comments for details, here is a cleaner version of your code which should work first time / every time!
Sub m_Range_End_Method()
Dim col As Range
Dim rng As Range
Dim currentRow As Long
' Use a With block to 'Fully Qualify' the ranges to MySheet
With ThisWorkbook.Sheets("MySheet")
' Set col range to the intersection of used range and column B
Set col = Intersect(.UsedRange, .Columns("B"))
' Loop through cells in col to set description in each row
For Each rng In col
currentRow = rng.Row
' Check upper case value match against upper case string
If InStr(UCase(rng.Value), "PETROL") > 0 Then
.Cells(currentRow, 5) = "Shopping"
.Cells(currentRow, 6) = "Car"
End If
Next rng
End With
End Sub
I have an excel file like
Original File
I want to transform all the cells that filled with information into a single column. Like
To transform This
How to i do this ?
I searched in internet about that i found just only transform cells in a single row to a single cell. But i couldn't find anything like this. Can you help me about that
This is a bit of code I keep around for this kind of job. It assumes that the values in each row are contiguous, that is there are no blank cells inside the data set. It also assumes that you're on the sheet that contains the data when you trigger it, and that you want the data to be placed on a new worksheet.
Option Explicit
Sub Columnise()
Dim shtSource As Worksheet
Dim shtTarget As Worksheet
Dim rngRow As Range, rngCol As Range
Dim lCount As Long
Set shtSource = ActiveSheet 'Or specify a sheet using Sheets(<name>)
Set rngCol = Range("A1", Range("A" & Rows.Count).End(xlUp))
Set shtTarget = Sheets.Add 'Or specify a sheet using Sheets(<name>)
'Define starting row for the data
lCount = 1
'Loop through each row
For Each rngRow In rngCol
'On each row, loop through all cells until a blank is encountered
Do While rngRow.Value <> ""
'Copy the value to the target
shtTarget.Range("A" & lCount).Value = rngRow.Value
'Move one space to the right
Set rngRow = rngRow.Offset(0, 1)
'Increment counter
lCount = lCount + 1
Loop
Next rngRow
End Sub
You should end up with all the data in a single column on a new worksheet.
EDITED TO ADD: Since you mentioned your data does contain blank cells, it gets more complicated. We'll want to add a way to continue to the actual end of the data, rather than just looping until we hit a blank cell. We'll modify the Do While... condition to this:
Do While rngCell.Column <= Cells(rngCell.Row, Columns.Count).End(xlToLeft).Column
This will loop until the end of the data in the row, then move on. Give it a shot and let us know.