I just populated a table via an algorithm with data from an Autodesk file. A good many of the fields are empty, and, in fact, a number of columns are empty but for a few rows. There are roughly 1300 columns, and I'm trying to trim that down.
Can anyone help me out with the VBA to remove a column if there are more than 1000 rows where the column is empty? I don't really know any VBA, so I don't know where to begin...
I'm trying something like this:
Sub ClearColumns()
'
' ClearColumns Macro
' Check to see if more than 1000 rows of a column are empty. If so, delete the column.
Dim iColumn As Long
Dim iRow As Long
Dim iColumnMax As Long
Dim iRowMax As Long
Dim iEmptyCount
iColumnMax = 13000
iRowMax = 20000
For iColumn = 1 To iColumnMax
For iRow = 1 To iRowMax
If (Cells(iRow, iColumn) = "") Then iEmptyCount.Add (1)
End If
If (iEmptyCount > 999) Then Columns(iColumn).Delete
Step 1
End If
Step 1
Application.Goto Reference:="ClearColumns"
End Sub
But again, I don't know what I'm doing. Any help/feedback is appreciated
Sub DeleteColumns()
Dim ColNumber as Long
For ColNumber = 1300 to 1 Step -1
If WorksheetFunction.CountBlank(Cells(1, ColNumber).Resize(20000,1)) > 1000 Then
Cells(1,ColNumber).EntireColumn.Delete
End If
Next
End Sub
Here is a code that removes a completely empty column.
The last column is allocated on the first line, that is, the stub cell in the first line must be filled with any sign.
Sub DeleteColumns()
Dim i As Long, lc As Long, lr As Long
lc = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To lc
lr = Cells(Rows.Count, i).End(xlUp).Row
If IsEmpty(Cells(lr, i)) = True Then
Cells(lr, i).EntireColumn.Delete
i = i - 1
lc = Cells(1, Columns.Count).End(xlToLeft).Column
If lc = i Then Exit For
End If
Next i
End Sub
This is credited to #Jeeped from a 2015 solution. It will remove all empty cells in your used range.
With Worksheets("name of your worksheet")
.UsedRange.Cells.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End With
Related
I have written a VBA code to select any row where a special value appears in a chosen column.
`Sub test()
vonZeile = 4 ' first row
bisZeile = Cells(vonZeile, 7).End(xlDown).Row
Spalte = 7 ' column G
Markierung = False
For Zeile = bisZeile To vonZeile Step -1
If (Cells(Zeile, Spalte).Value = "Werkstatt") Then
If Markierung Then
Union(Selection, Rows(Zeile)).Select
Else
Rows(Zeile).Select
Markierung = True
End If
End If
Next Zeile
If Zeilen > "" Then Selection.Delete Shift:=xlUp
End Sub`
This might not be the prettiest but it works pretty well and very fast.
Now I would like to change this code so that the rows with the specific value are not only selected but cut out or hidden.
I couldn't figure out how to change this code to get this.
I have a different code that does delete all these rows but it lats an eternity. But it should be much faster when all the rows with the specific value would be deleted at once.
Shouldn't there be a way to just change the .Select part in the code to maybe Hidden or Delete?
This is just a guessing as I am not very familiar with VBA coding.
Very happy to get some advice on this matter.
Thanks
Here's the fastest way I've found to do this: create an array the size of your original data, loop through the rows adding the keepers to the array, then clear all of the data from the worksheet(far less time consuming than deleting) and then lastly write the array of stored data to the sheet.
Option Explicit
Sub test()
Dim ws As Worksheet
Dim firstRow As Integer, lastRow As Integer
Dim lastCol As Integer, criteriaCol As Integer
Dim criteriaValue As Variant
Dim arr As Variant
Dim iRow As Integer, iCol As Integer, iCounter As Integer
'Set this to the worksheet you want to perform this procedure on
Set ws = ActiveSheet
'Set your first row, last row, criteria column, and last column
firstRow = 4
lastRow = Cells(firstRow, 7).End(xlDown).Row
lastCol = 7
criteriaCol = 7
criteriaValue = "Werkstatt"
'Resize the array to fit the length of your sheet
ReDim arr(1 To (lastRow - firstRow), 1 To lastCol)
'iCounter is used to track the position of the first dimension in arr
iCounter = 1
'For each row, if the value you are looking for matches then loop through each column and write it to the array
For iRow = firstRow To lastRow
If ws.Cells(iRow, criteriaCol).Value = criteriaValue Then
For iCol = 1 To lastCol
arr(iCounter, iCol) = ws.Cells(iRow, iCol)
Next
iCounter = iCounter + 1
End If
Next iRow
'Clear the specific rows on the sheet
ws.Rows(firstRow & ":" & lastRow).Cells.Clear
'Resize the range to fit the array and write it the worksheet
ws.Cells(firstRow, 1).Resize(firstRow + iCounter - 1, lastCol) = arr
End Sub
I now found the answer to my problem. It is just a change of one single line. I deleted the last line in my code If Zeilen > "" Then Selection.Delete Shift:=xlUp and replaced it by the following line Selection.EntireRow.Delete. This solves the problem and it also works fast which was very important to me. Thanks everyone for the help!
I am trying to Sum every 3rd row in column "K", starting from K2 to the last cells used. Please note, the data or cells used in column "K" will vary.
I need a macro to sum the values in every 3rd row til the last row used and show the Total in "M1".
I attached a snapshot of some sample values and what I would like the end result to look like.
Short and slow (tested and in Excel it works only as an array formula):
[M1] = [SUM(IF(MOD(ROW(K:K),3)=1,K:K))]
or a bit longer by limiting the range:
[M1] = Evaluate(Replace("SUM(K2:K9*(MOD(ROW(2:9),3)=1))", 9, [K1].End(xlDown).Row))
Howdee Tom - This should do the trick for you.
Sub Sum_Every_Third()
Dim sht As Worksheet
Dim lastRow As Long, amount As Long
Set sht = Worksheets("Sheet1") 'Be sure to change to your correct sheet name
lastRow = sht.UsedRange.Rows(sht.UsedRange.Rows.Count).Row
amount = 0
For i = 2 To lastRow
If Cells(i, 13).Offset(-1, 0).Row Mod 3 = 0 Then ' Make sure you change 13 to your column number
amount = amount + Cells(i, 13).Value
End If
Next i
MsgBox amount
End Sub
This sub should achieve your summing, see comments for details
Sub dosum()
' Get last row
Dim lastrow As Long
lastrow = ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Cells.Count).Row
' Assign range object to data in column K
Dim myRange As Range
Set myRange = ActiveSheet.Range("K2:K" & lastrow)
' Sum every third item
Dim i As Long
Dim mySum As Double
mySum = 0
' Step through cells in range, 3 at a time
For i = 3 To myRange.Cells.Count Step 3
mySum = mySum + myRange.Cells(i).Value
Next I
' Put in cell
ActiveSheet.Range("M1").Value = mySum
End Sub
I need some help with this macro. I have a workbook that is formatted pretty poorly, but consistently every time I open it. Among other things, the goal is to find the non-blank cells in column B and delete the entire 2 rows below and the 1st row above each of those populated B cells.
The first loop I have in the code works just the way I want it to, but the second loop seems to only work on the 1st instance of a populated B cell, but then it deletes everything else above it, like 500 cells worth of data.
Can someone explain to me why this is happening, and if you could find a way to combine both of those for loops into 1, that would be nice too.
Sub test()
Dim currentSht As Worksheet
Dim startCell As Range
Dim lastRow As Long, lastCol As Long
Dim colNames As Variant
Dim i As Integer, j As Integer
Set currentSht = ActiveWorkbook.Sheets(1)
Set startCell = currentSht.Range("A1")
lastRow = startCell.SpecialCells(xlCellTypeLastCell).Row
lastCol = startCell.SpecialCells(xlCellTypeLastCell).Column
For i = lastRow To 1 Step -1
If currentSht.Cells(i, "B").Value <> "" Then
currentSht.Cells(i, "B").Offset(1).EntireRow.Delete
End If
Next i
Range("D3").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlUp
currentSht.Rows("1:1").EntireRow.Delete
currentSht.Range("c:d, f:g, i:k").EntireColumn.Delete
currentSht.Range("A:D").Columns.AutoFit
For j = lastRow To 2 Step -1
If currentSht.Cells(j, "B").Value <> "" Then
currentSht.Range(Cells(j, "B").Offset(-1), Cells(j, "B").Offset(-3)).EntireRow.Delete
End If
Next j
End Sub
Thank you
The second loop deletes everything because upon deletion of the lines above the found value, said value gets moved up and will be found again, triggering another deletion. To fix this, the quickest way would be to skip the next two lines by modifying j:
For j = lastRow To 2 Step -1
If currentSht.Cells(j, "B").Value <> "" Then
currentSht.Range(Cells(j, "B").Offset(-1), Cells(j, "B").Offset(-3)).EntireRow.Delete
j = j - 2
End If
Next j
It really doesn't matter much if you are looping from top to bottom or vice versa. The only difference would be if there are two entries in column B near each other. In that case, the search order would determine which one is deleted. But is deletion really what you want? Maybe you could .Clear the contents of the rows instead of deleting them.
edit: here's the new code a bit cleaned up
Sub test()
Dim currentSht As Worksheet
Dim startCell As Range
Dim lastRow As Long, lastCol As Long
Dim colNames As Variant
Dim i As Integer, j As Integer
Set currentSht = ActiveWorkbook.Sheets(1)
Set startCell = currentSht.Range("A1")
lastRow = startCell.SpecialCells(xlCellTypeLastCell).Row
lastCol = startCell.SpecialCells(xlCellTypeLastCell).Column
For i = lastRow To 1 Step -1
If currentSht.Cells(i, "B").value <> "" Then
'reference the row directly
currentSht.Rows(i + 1).Delete
End If
Next i
'Do not use selection if you can avoid it
Range("D3", Range("D3").End(xlToRight)).Delete Shift:=xlUp
currentSht.Rows(1).Delete
currentSht.Range("C:D, F:G, I:K").Delete
currentSht.Range("A:D").Columns.AutoFit
For j = lastRow To 2 Step -1
If currentSht.Cells(j, "B").value <> "" Then
currentSht.Rows(j - 1).Delete
currentSht.Rows(j - 2).Delete
j = j - 2
End If
Next j
End Sub
If you want to combine the loops the behavior of the macro will change because of the deletions that happen between the loops.
I am trying to piece together code to make my macro work correctly. This approach has served me well in the past but I cannot seem to adapt any code correctly.
I found the following
Sub way()
Dim Cell As Range
For Each Cell In Range("A1").CurrentRegion
If Len(Cell) < 2 Then Cell.EntireRow.Delete
Next Cell
End Sub
I can adapt the If Len(Cell) criteria to my liking. For example = 10
I do not know how to adapt the code to make it search through all cells in column A and delete the appropriate rows. The code above only does it for A1.
Ideally I would like to delete all rows with cells in column A that have a length of 10 characters. Or alternatively, with a completely different set of code, delete all other rows that do not contain cells in column A that have a length of 10 characters.
When deleting rows it is best to loop backwards:
Sub way()
Dim ws As Worksheet
Dim i As Long
Dim lastrow As Long
Set ws = ActiveSheet
lastrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
For i = lastrow To 1 Step -1
If Len(ws.Cells(i, 1)) < 2 Then ws.Rows(i).Delete
Next i
End Sub
Essentially, your loop is going through every cell in the Range.CurrentRegion property radiating out from A1. Your narrative expresses that you only want to examine column A but delete the Range.EntireRow property.
The For .. Next loop stepping backwards proposed by Scott Craner is likely your best bet but if you are more comfortable with a For ... Each In loop then yours can be adjusted.
Sub way()
Dim cl As Range, dels As Range
With Worksheets("Sheet1")
For Each cl In .Range("A1").CurrentRegion.Columns(1).Cells
If Len(cl.Value2) = 10 Then
If Not dels Is Nothing Then
Set dels = Union(dels, cl)
Else
Set dels = cl
End If
End If
Next cl
End With
If Not dels Is Nothing Then _
dels.EntireRow.Delete
End Sub
The logic to delete rows that did not have a value in column A that was 10 characters, symbols or digits long would be If Len(cl.Value2) <> 10 Then.
I haven't checked for syntax, but something like this should work:
dim idx as integer
idx = 1
while Range("A" + cstr(idx)).value <> ""
'insert your delete logic here...
idx = idx + 1
wend
I think I need a loop function for this but i'm not sure how to go about it.
The task for this is to see if a specific column is blank, then to delete that row. But sometimes there is no blank cells and i am getting a end debug error.
Here is my code:
Sub DeleteRow()
Dim lr As Long
Dim shCurrentWeek As Worksheet
Set shCurrentWeek = AciveWorkbook.Sheets("Current Week")
lr = shCurrentWeek.Range("A" & Rows.Count).End(xlUp).Row
'Delete Row
shCurrentWeek.Range("B4:B" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
any ideas?
How about just putting on error resume next right before your Delete line? LIke this:
On error resume next
shCurrentWeek.Range("B4:B" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
I'm assuming you don't care if it fails, so there's no need to do error trapping. This will keep an error message from displaying if there are no cells returned from your call to SpecialCells.
While Daniel Cook is right, you could use On Error Resume Next, here is another way of going about it, since using On Error Resume Next is really a last resort option in VBA (IMO).
The code below checks for blanks before it tries to use the SpecialCells method.
Option Explicit
Sub DeleteRow()
Dim lr As Long
Dim shCurrentWeek As Worksheet
Set shCurrentWeek = ActiveWorkbook.Sheets("Current Week")
lr = shCurrentWeek.Range("A" & Rows.Count).End(xlUp).Row
If Application.WorksheetFunction.CountBlank(shCurrentWeek.Range("B4:B" & lr)) <> 0 Then
shCurrentWeek.Range("B4:B" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
End Sub
Here is a piece of code I use for that type of operation.
Sub ClearBlank()
Dim i As Long
For i = Range("B65536").End(xlUp).Row To 8 Step -1
If IsEmpty(Cells(i, 4)) Then Rows(i).Delete
Next i
End Sub
I hope this helps!
Not used VBA before today so I'm sure there is a neater way...but this code will delete any row with at least one empty cell. It assumes that you have a header row and that the first column is used for IDs so these cells are not 'looked at'.
The nice thing about this script is that it works for any size of spreadsheet so you don't need to hard-code values each time:
Sub DeleteIncompleteRows()
Dim row As Integer, col As Integer
Dim deleted As Integer
deleted = 0
Dim actualRow As Integer
Dim totalRows As Integer
Dim totalCols As Integer
totalRows = Application.CountA(Range("A:A"))
totalCols = Application.CountA(Range("1:1"))
For row = 2 To totalRows
actualRow = row - deleted
For col = 2 To totalCols
If ActiveSheet.Cells(actualRow, col).Value = "" Then
ActiveSheet.Rows(actualRow).Delete
deleted = deleted + 1
Exit For
End If
Next col
Next row
End Sub
All the best,
Scott