This question already has answers here:
How to find out if an entire row is blank in excel thorough vba
(2 answers)
Closed 4 years ago.
In my macro, I want to delete completely blank Rows. Not Rows that has something in one column because that is still valuable information.
I have looked all over the internet but if someone could come up with a function that deletes ENTIRELY blank rows and not just rows with something missing in a few columns that would be awesome.
(Information is only on Columns A through N and roughly 7 thousand rows). I haven't developed any code for this because I am really stumped.
You can use this...
Sub ClearEmptyRows()
Dim r As Long, lastrow As Long, WS As Worksheet, killRng As Range
Set WS = ActiveSheet
lastrow = WS.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Set killRng = WS.Rows(Rows.Count)
For r = 1 To lastrow
If Application.WorksheetFunction.CountA(WS.Rows(r)) = 0 Then
Set killRng = Union(killRng, WS.Rows(r))
End If
Next r
killRng.Delete
End Sub
A couple comments on this code for newbies as it's a common routine to loop through rows and do something (delete, highlight, hide, etc.)
It's always best to interact with Worksheet as infrequently as possible. Thus we execute the Delete AFTER all of the rows have been identified.
You can't Union an empty range, so I set the killRng to initially be the entire last row (hopefully this is always blank), and then the macro can proceed with Union. One could get around this by including an if-statement, but this requires the macro check if range exists on each row.
If you just want to remove empty rows and are not concerned about formatting this is super fast.
Sub RemoveEmptyRows()
Dim results As Variant, Target As Range
Dim c As Long, r As Long, n As Long
Set Target = Worksheets("Sheet1").UsedRange
If Target.Count > 0 Then
ReDim results(1 To Target.Rows.Count, 1 To Target.Columns.Count)
For r = 1 To Target.Rows.Count
If WorksheetFunction.CountA(Target.Rows(r)) > 0 Then
For c = 1 To Target.Columns.Count
n = n + 1
results(n, c) = Target.Cells(r, c).Value
Next
End If
Next
End If
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Target.Value = results
Application.ScreenUpdating = xlCalculationAutomatic
Application.ScreenUpdating = False
End Sub
Related
I have a sheet with about 6000 rows. In my code I first filter out some rows.
Sheets("privata").Rows("2:" & Rows.count).AutoFilter Field:=26, Criteria1:=">=2020-01-30 09:00:00", Operator:=xlAnd, Criteria2:="<=2020-01-30 09:30:00"
Sheets("privata").Rows("2:" & Rows.count).AutoFilter Field:=24, Criteria1:="<>OK"
Sheets("privata").Rows("2:" & Rows.count).AutoFilter Field:=25, Criteria1:="<>SUPPLY_CONTROL,"
Its now down to about 350 rows. After I've filtered it I copy and paste the data to another sheet
Sheets("privata").UsedRange.Copy
Sheets("toptre").Range("A1").PasteSpecial xlPasteAll
After I've copied the data I work on it in various ways in the new sheet.
The entire code takes a while to run. After stepping through the code I discovered that the filtering out process is super quick. What takes time is the pasting of the data in to the other sheet.
Is there a possibility to work with the original filtered sheet? When I try to, it uses all 6000 rows, not just the filtered out ones.
Example of what I want to do:
For i = 2 To RowCount + 1
employee = Sheets("privata").Cells(i, 25)
onList = False
For j = 1 To UBound(employeeList)
If employee = employeeList(j) Then
onList = True
Exit For
End If
Next j
If onList = False Then
countEmployees = countEmployees + 1
employeeList(countEmployees) = employee
End If
If onList = True Then
onList = False
End If
Next i
When referring to Cells(2, 25) I want to refer to the second row in the filtered sheet. Which might be row 3568 in the sheet. Is that possible?
/Jens
After the filtering has been applied, you can make the copy/paste process very fast if you don't use a loop, but use Selection. For example:
Sub TryThis()
Dim r As Range
Sheets("privata").Select
Set r = ActiveSheet.AutoFilter.Range
r.Select
Selection.Copy Sheets("toptre").Range("A1")
End Sub
Usually you want to avoid Selection in VBA. However, you will end up with:
a block of data in sheet "toptre"
the block will include the header row and all visible rows
the block will be just a block (un-filtered)
I am not sure if this will make your process any faster, but it attempts to accomplish what you ask about in your question:
You could use the expression suggested by #GSerg 's comment to create a range object with only the visible rows in the data sheet, e.g.
Dim filteredRange As Range
Set filteredRange = Sheets("privata").UsedRange.Rows.SpecialCells(xlCellTypeVisible)
Assuming there is at least 1 visible row in the sheet (meaning that the above statement will not throw an error), you could then use the following function to access that range as if it were a single, contiguous range:
Function RelativeCell(rng As Range, ByVal row As Long, ByVal col As Long) As Range
Dim areaNum As Long: areaNum = 0
Dim maxRow As Long: maxRow = 0
Dim areaCount As Long: areaCount = rng.Areas.Count
Do While maxRow < row
areaNum = areaNum + 1
If areaNum > areaCount Then
Set RelativeCell = Nothing
Exit Function
End If
maxRow = maxRow + rng.Areas(areaNum).Rows.Count
Loop
Dim lastArea As Range: Set lastArea = rng.Areas(areaNum)
Set RelativeCell = lastArea.Cells(row - (maxRow - lastArea.Rows.Count), col)
End Function
To print all the filtered values in column B, for example, you could use the above method on the filteredRange object (set earlier) this way:
Dim r As Long: r = 1
Do
Dim cell As Range: Set cell = RelativeCell(filteredRange, r, 2)
If cell Is Nothing Then Exit Do
Debug.Print cell.Value
r = r + 1
Loop
To simplify the above code, you could also use a function to know the last relative row number in the filtered range using the following function:
Function RelativeCellLastRow(rng As Range) As Long
Dim r As Long: r = 0
Dim i As Long
For i = 1 To rng.Areas.Count
r = r + rng.Areas(i).Rows.Count
Next
RelativeCellLastRow = r
End Function
Then, the code to print all the filtered values in column B would be reduced to this:
Dim r As Long
For r = 1 To RelativeCellLastRow(filteredRange)
Debug.Print RelativeCell(testRng, r, 2).Value
Next
If you use RelativeCellLastRow, it would be good to ensure that it is only executed once, to avoid unnecessary recalculations. In the For loop above, it is only executed once, since VBA only executes the limits of a For loop before the first iteration. If you need the value several times, you can store it in a variable and use the variable instead.
The idea behind the RelativeCell function is that the range returned by the call to SpecialCells is a multi-area range, i.e. a range made up of several non-contiguous ranges. What relativeCell does is to skip through the non-contiguous areas until it finds the row number it is looking for. If the row number is beyond the total number of rows in the range, the function returns Nothing, so the calling code must be aware of this to avoid calling a method or property on Nothing.
It is also worth nothing that RelativeCell works on a range with hidden rows, not hidden columns. With hidden columns, the code becomes a little more complex, but the complexity can be encapsulated in the RelativeCell function without affecting the code that uses the function.
Again, I am not sure whether this will make your code faster. When I did some tests to emulate your scenario using a sheet with 6000+ rows and 30 columns of random strings, the copy/paste after the filtering ran very quickly, but it could be because of the machine I am using, the version of Excel that I am using (2016), or the data I used. Having said that, I hope the above code is of some help.
I have VBA running on an Excel sheet that translates the data in the sheet so I can import it into another application.
The below function cleans the data and removes text wrapping. This function takes a long time to run when the sheets have a large cell count. Since I am normalizing data to import to a relational database, there are frequently a lot of cells across the seven different sheets I have.
Is there a more efficient way to remove the text wrap and clean the data in the cells?
Dim ws As Worksheet
Dim x, lrow, lcol, active As Long
Dim r, cel As Range
active = ActiveWorkbook.Worksheets.count
For x = 1 To active
Set ws = ThisWorkbook.Sheets(x)
ws.Select
Select Case ws.name
Case "Solution", "Description", "Problem", "Buyer", "ProjectType", "Process", "Feature"
lrow = ws.UsedRange.Rows(ActiveSheet.UsedRange.Rows.count).row
lcol = ws.UsedRange.Columns(ActiveSheet.UsedRange.Rows.count).Column
If lrow > 1 Then
Set r = ws.Range(Cells(2, 1), Cells(lrow, lcol))
For Each cel In r.Cells
cel.WrapText = False
cel.Value = Application.WorksheetFunction.Clean(cel.Value)
Next cel
End If
Case Else
End Select
ws.Cells(1, 1).Select
ThisWorkbook.Sheets("Solution").Activate
Next x
Your code can be reduced to
Sub Demo()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Select Case ws.Name
Case "Solution", "Description", "Problem", "Buyer", "ProjectType", "Process", "Feature"
With ws.UsedRange
.WrapText = False
.Value = ws.Evaluate("Clean(" & .Address & ")")
End With
End Select
Next
End Sub
On my hardware, a sheet with 100,000 rows 26 columns ran in about 6s
Note: OPs claim (in comment) that "it changes the value of every cell on the sheet to the first value in the first sheet it encounters." - tested this claim and it's not accurate. This code works as advertised.
To remove the text wrapping property (and it surprises me that has an affect on your external program), you should be able to do just:
r.WrapText = False
For the Clean, what, exactly, is in the cells that you are trying to remove?
It would be faster to read the cells into an array; process them, and write them back.
Something like: (not debugged)
Dim V, I as long, J as Long
v = R
for i = 1 to ubound(v)
for j = 1 to ubound(v,2)
`worksheetfunction.clean(v(i,j))
`or some other function to remove unwanted characters
next j
next i
r.clear
r.value = v
You should also be aware that UsedRange is not particularly reliable and may wind up with you processing many more cells than necessary.
There are a number of posts on this forum showing better methods of determing the Last Row and Last Column.
I have data regarding benefits. At the bottom of these worksheets are adjustments. These should not be used in my Macros and formulas.
Instead of manually deleting, I'd like VBA to find "Adjustments" and delete that row and all rows below this. I have 3 worksheets I needs to this to repeat on.
I've googled and tried various codes but cannot seem to get it to read properly. Can anyone help?
First step is to find the first row of your Adjustments. You'll use .Find method to get that. Below is a sample line of code. You can google for more details and examples.
Once you have that, you'll find the last row, and then delete rows from start of adjustment rows to last row. I've included functions below that should help.
Set foundCell = rng.Cells.Find(varSearchValue, celStartCell, enuXlFindLookIn, enuXlLookAt)
Public Function LastUsedRow(wks As Worksheet) As Long
Dim rng As Range: Set rng = wks.UsedRange ' Excel will recalc used range
LastUsedRow = rng.Row + rng.Rows.Count - 1
End Function
Public Sub DeleteRows(wks As Worksheet, lngRowStart As Long, Optional ByVal lngRowEnd As Long = 0)
If lngRowEnd = 0 Then lngRowEnd = lngRowStart
wks.Rows(lngRowStart & ":" & lngRowEnd).Delete
End Sub
I've inferred that Adjustments is some sort of sub-level header row label. I'll assume that it is always in column A.
sub ScrubAdjustments()
dim w as long, wss as variant, m as variant
wss = array("sheet1", "sheet2", "sheet3")
for w = lbound(wss) to ubound(wss)
with worksheets(wss(w))
m = application.match("adjustments", .range("a:a"), 0)
if not iserror(m) then
.range(.cells(m, "A"), .cells(.rows.count, "A")).entirerow.delete
end with
end with
next w
end sub
I see several posts about deleting blank rows in a range and others about deleting table rows based on a single blank column, but nothing about deleting entirely blank table rows.
What's the quickest way to do this?
I posted my solution below to help others but I'm interested to see if anyone has a faster method.
Here's a procedure I use to delete blank table rows. I sometimes work with large (for Excel) data sets and this method is faster. It loads table rows into an array, checks the array for blank rows, and performs one range.delete operation at the end.
You use the procedure like this:
Sub Test()
DeleteBlankTableRows ActiveSheet.ListObjects(1)
End Sub
ActiveSheet.ListObjects(1) is (usually) the first table table on the active worksheet.
Here's the actual procedure:
Sub DeleteBlankTableRows(ByVal tbl As ListObject)
Dim rng As Range
Set rng = tbl.DataBodyRange ' Get table data rows range.
Dim DirArray As Variant
DirArray = rng.Value2 ' Save table values to array.
' LOOP THROUGH ARRAY OF TABLE VALUES
Dim rowTMP As Long
Dim colTMP As Long
Dim combinedTMP As String
Dim rangeToDelete As Range
' Loop through rows.
For rowTMP = LBound(DirArray) To UBound(DirArray)
combinedTMP = vbNullString ' Clear temp variable.
' Loop through each cell in the row and get all values combined.
For colTMP = 1 To tbl.DataBodyRange.Columns.Count
combinedTMP = combinedTMP & DirArray(rowTMP, colTMP)
Next colTMP
' Check if row is blank.
If combinedTMP = vbNullString Then
' Row is blank. Add this blank row to the range-to-delete.
If rangeToDelete Is Nothing Then
Set rangeToDelete = tbl.ListRows(rowTMP).Range
Else
Set rangeToDelete = Union(rangeToDelete, tbl.ListRows(rowTMP).Range)
End If
End If
Next rowTMP
' DELETE BLANK TABLE ROWS (if any)
If Not rangeToDelete Is Nothing Then rangeToDelete.Delete
End Sub
This has some advantages over other methods:
SPEED: In a test of a table with 200,000 rows and 8 columns, this method took 19 seconds. That's just over half the 34 seconds the SpecialCells(xlCellTypeBlanks) method needed for an identical table.
IDENTIFIES FULLY BLANK TABLE ROWS: Unlike some other methods (like this one - although it is useful in some situations) this method looks for blanks in every cell of a row instead of just one.
This should work. Not sure if it's faster, but it's another way to do it:
Sub delete_blank_table_rows()
Dim Rng As Range, tempRng As Range
Set Rng = Range("Table1") ' Change as necessary
Set Rng = Range(Cells(Rng.Rows(1).Row, Rng.Columns(1).Column), Cells(Rng.Rows(Rng.Rows.Count).Row, Rng.Columns(Rng.Columns.Count).Column))
Dim i As Long
For i = Rng.Rows.Count To 1 Step -1
Cells(Rng.Rows(i).Row, Rng.Columns(1).Column).Select
Set tempRng = Range(Cells(Rng.Rows(i).Row, Rng.Columns(1).Column), Cells(Rng.Rows(i).Row, Rng.Columns(Rng.Columns.Count).Column))
If WorksheetFunction.CountA(tempRng) = 0 Then
tempRng.Delete shift:=xlUp
End If
Next i
End Sub
Edit: And of course to speed it up you should turn off Screen Updating, Calculation while it runs.
I think this may be faster (you can modify lastrow and lastcol to meet your table dimensions):
Sub delete_rows_blank2()
t = 1
lastrow = ActiveSheet.UsedRange.Rows.Count
lastcol = ActiveSheet.UsedRange.Columns.Count
Do Until t = lastrow
For j = 1 To lastcol
If Cells(t, j) = "" Then
j = j + 1
If j = lastcol Then
Rows(t).Delete
t = t + 1
End If
Else
t = t + 1
End If
Next
Loop
End Sub
I am trying to use loop for merging 10 cells which will have same data in column A:
A2 to A11 will have L001-AIG Life & Retirement10002-0001-US GAAP--
A12 to A21 Will have 0248-Parent & Other-2000002-0002-US GAAP--
like this we will have data until 1000's of line which i need to merge manually to prepare a final report but i am not getting it to use loop for merging cells like 'A2-A11', 'A12-A21' to Until lastrow based on Column 'G' which no need to merge
Option Explicit
Sub Insert()
Dim i As Long
Dim Ws As Worksheet
Application.DisplayAlerts = False
Set Ws = ThisWorkbook.Sheets("Sheet1")
With Ws
Dim MyLastRow As Long
MyLastRow = Cells(Rows.Count, "G").End(xlUp).Row
'Loop through range backwards and merge
For i = 2 To MyLastRow
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(10, 0)).Merge
Next i
End With
End Sub
Similar to this we have to merge 10 rows same data from Column B, C, D E, F, J, K & L along with Column A.
I am trying it from last few days online everywhere but not got anything matching to my requirement, would be of great help if any one can help me out with this..
Thanks a lot for your time and help!
Have a great weekend !
Regards
Suresh
Something like this should work for you:
EDIT Updated per OP request with new requirement:
Similary i wanted to use this for other 7 seven columns (B-F & J-L)
Can this be edited to adjust all columns in single code?
Sub Insert()
Dim ws As Worksheet
Dim ColumnCell As Range
Dim rIndex As Long
Dim sColumns As String
sColumns = "A:F,J:L"
Set ws = ThisWorkbook.Sheets("Sheet1")
Application.DisplayAlerts = False
For rIndex = 2 To ws.Cells(ws.Rows.Count, "G").End(xlUp).Row Step 10
For Each ColumnCell In Intersect(ws.Rows(1), ws.Range(sColumns)).Cells
ws.Cells(rIndex, ColumnCell.Column).Resize(10).Merge
Next ColumnCell
Next rIndex
Application.DisplayAlerts = True
End Sub