Most efficient way to delete row with VBA - excel

I currently have a macro that I use to delete a record if the ID doesn't exist in a list of ID's I created from an XML document. It does work like I want it to, however I have over 1000 columns in the spreadsheet (one for each day of the year until end of 2015) so it takes ages to delete the row and it can only do 1 or 2 before it says "Excel ran out of resources and had to stop". Below is the code I'm using for the macro, is there another way I can do this so that Excel doesn't run of of resources?
Sub deleteTasks()
Application.ScreenUpdating = False
Dim search As String
Dim sheet As Worksheet
Dim cell As Range, col As Range
Set sheet = Worksheets("misc")
Set col = sheet.Columns(4)
ActiveWorkbook.Sheets("Schedule").Activate
ActiveSheet.Range("A4").Select
ActiveSheet.Unprotect
ActiveSheet.Range("A:C").EntireColumn.Hidden = False
Do While ActiveCell.Value <> ""
search = ActiveCell.Value
Set cell = col.Find(What:=search, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If cell Is Nothing Then 'If the taskID is not in the XML list
Debug.Print "Deleted Task: " & ActiveCell.Value
Selection.EntireRow.Delete
End If
ActiveCell.Offset(1, 0).Select 'Select next task ID
Loop
ActiveSheet.Range("A:B").EntireColumn.Hidden = True
ActiveSheet.Protect
End Sub
After trying lots of different options, including all the answers listed below. I have realized that whatever the method is, deleting a row with ~1100 columns is going to take a while on my average laptop (2.20 Ghz, 4GB RAM). Since the majority of the rows are empty I have found alternative method which is a lot faster. I just clear the cells which contain data (A:S) and then resize the table to remove the row where I just deleted the data from. This end result is exactly the same as entireColumn.Delete. Below is the code I'm using now
'New method - takes about 10 seconds on my laptop
Set ws = Worksheets("Schedule")
Set table = ws.ListObjects(1)
Set r = ws.Range("A280:S280")
r.Clear
table.Resize Range("A3:VZ279")
Using anything involving EntireColumn.Delete or just manually selecting the row and deleting it takes about 20-30 seconds on my laptop. Of course this method only works if your data is in a table.

The short answer:
Use something like
ActiveSheet.Range(DelStr).Delete
' where DelStr = "15:15" if you want to delete row 15
' = "15:15,20:20,32:32" if you want to delete rows 15,20 and 32
The long answer:
Important: If you have ~ 30 / 35 rows to delete, the following code works very efficiently. Beyond which it would throw up an error. For code to handle arbitrary number of rows efficiently see the very long answer below this.
If you have a function which lets you list out which rows you want to delete, try the code below. This is what I use to very efficiently delete multiple rows with minimum overhead. (the example assumes that you've obtained the rows you need to delete through some program, here I manually feed them in):
Sub DeleteRows()
Dim DelRows() As Variant
ReDim DelRows(1 To 3)
DelRows(1) = 15
DelRows(2) = 18
DelRows(3) = 21
'--- How to delete them all together?
Dim i As Long
For i = LBound(DelRows) To UBound(DelRows)
DelRows(i) = DelRows(i) & ":" & DelRows(i)
Next i
Dim DelStr As String
DelStr = Join(DelRows, ",")
' DelStr = "15:15,18:18,21:21"
'
' IMPORTANT: Range strings have a 255 character limit
' See the other code to handle very long strings
ActiveSheet.Range(DelStr).Delete
End Sub
The (very long) efficient solution for arbitrary number of rows and benchmark results:
Here are the benchmark results obtained by deleting rows (Time in seconds vs. no. of rows).
The rows are on a clean sheet and contain a volatile formula in the D column from D1:D100000
i.e. for 100,000 rows, they have a formula =SIN(RAND())
The code is long and not too pretty, but it splits the DelStr into 250 character substrings and forms a range using these. Then the new DeleteRng range is deleted in a single operation.
The time to delete may depend on the contents of the cells. The testing/benchmarking, in congruence with a bit of intuition suggests the following results.
Sparse rows/empty cells delete fastest
Cells with values take somewhat longer
Cells with formulas take even longer
Cells which feed into formulas in other cells take longest as their deletion triggers the #Ref reference error.
Code:
Sub DeleteRows()
' Usual optimization
' Events not disabled as sometimes you'll need to interrupt
' You can optionally keep them disabled
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
' Declarations...
Dim DelRows() As Variant
Dim DelStr As String, LenStr As Long
Dim CutHere_Str As String
Dim i As Long
Dim MaxRowsTest As Long
MaxRowsTest = 1000
' Here I'm taking all even rows from 1 to MaxRowsTest
' as rows to be deleted
ReDim DelRows(1 To MaxRowsTest)
For i = 1 To MaxRowsTest
DelRows(i) = i * 2
Next i
'--- How to delete them all together?
LenStr = 0
DelStr = ""
For i = LBound(DelRows) To UBound(DelRows)
LenStr = LenStr + Len(DelRows(i)) * 2 + 2
' One for a comma, one for the colon and the rest for the row number
' The goal is to create a string like
' DelStr = "15:15,18:18,21:21"
If LenStr > 200 Then
LenStr = 0
CutHere_Str = "!" ' Demarcator for long strings
Else
CutHere_Str = ""
End If
DelRows(i) = DelRows(i) & ":" & DelRows(i) & CutHere_Str
Next i
DelStr = Join(DelRows, ",")
Dim DelStr_Cut() As String
DelStr_Cut = Split(DelStr, "!,")
' Each DelStr_Cut(#) string has a usable string
Dim DeleteRng As Range
Set DeleteRng = ActiveSheet.Range(DelStr_Cut(0))
For i = LBound(DelStr_Cut) + 1 To UBound(DelStr_Cut)
Set DeleteRng = Union(DeleteRng, ActiveSheet.Range(DelStr_Cut(i)))
Next i
DeleteRng.Delete
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
The code to generate the formulas in a blank sheet is
Sub FillRandom()
ActiveSheet.Range("D1").FormulaR1C1 = "=SIN(RAND())"
Range("D1").AutoFill Destination:=Range("D1:D100000"), Type:=xlFillDefault
End Sub
And the code to generate the benchmark results above is
Sub TestTimeForDeletion()
Call FillRandom
Dim Time1 As Single, Time2 As Single
Time1 = Timer
Call DeleteRows
Time2 = Timer
MsgBox (Time2 - Time1)
End Sub
Note: Many thanks to brettdj for pointing out the error which gets thrown when the length of DelStr exceeding 255 characters. It seems to be a known problem and as I painfully found out, it still exists for Excel 2013.

This code uses AutoFilter and is significantly faster than looping through rows.I use it daily and it should be pretty easy to figure out.Just pass it what you're looking for and the column to search in.You could also hard-code the column if you want.
private sub PurgeRandy
Call FindDelete("F", "Randy")
end sub
Public Sub FindDelete(sCOL As String, vSearch As Variant) 'Simple find and Delete
Dim lLastRow As Integer
Dim rng As Range
Dim rngDelete As Range
Range(sCOL & 1).Select
[2:2].Insert
[2:2] = "***"
Range(sCOL & ":" & sCOL).Select
With ActiveSheet
.UsedRange
lLastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
Set rng = Range(sCOL & 2, Cells(lLastRow, sCOL))
rng.AutoFilter Field:=1, Criteria1:=vSearch
Set rngDelete = rng.SpecialCells(xlCellTypeVisible)
rng.AutoFilter
rngDelete.EntireRow.Delete
.UsedRange
End With
End Sub

In this case a simple working formula can be used to see if each of the values in your range to be tested (column A of schedule) exist in column F of misc
In B4 it would =MATCH(A4,misc!D:D,0)
This can be used manually or with code for an efficient delete as the formula by design returns an error if there is no match which we can efficiently delete with VBA with either:
AutoFilter
SpecialCells (the design piece*)
In xl2007 note that there is a limit of 8192 discrete areas that can be selected with SpecialCells
code
Sub ReCut()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Set ws1 = Sheets("misc")
Set ws2 = Sheets("schedule")
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set rng1 = ws2.Range(ws2.[a4], ws2.Cells(Rows.Count, "A").End(xlUp))
ws2.Columns(2).Insert
With rng1.Offset(0, 1)
.FormulaR1C1 = "=MATCH(RC[-1],'" & ws1.Name & "'!C[2],0)"
On Error Resume Next
.Cells.SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
On Error GoTo 0
End With
ws2.Columns(2).Delete
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub

Note: I don't have enough "reputation" to add my comments thus posting as answer. Credit to hnk for wonderful answer (Long Answer). I have one edit as suggestion:
Once you split the long string and in case the last block is more than the set character then it is having "!" at the end which is throwing error for range method. Addition of IF statement and MID is ensuring that there is no such character.
To handle that, use:
For i = LBound(DelStr_Cut) + 1 To UBound(DelStr_Cut)
If Right(DelStr_Cut(i), 1) = "!" Then
DelStr_Cut(i) = Mid(DelStr_Cut(i), 1, Len(DelStr_Cut(i)) - 1)
Set DeleteRng = Union(DeleteRng, ActiveSheet.Range(DelStr_Cut(i)))
Else
Set DeleteRng = Union(DeleteRng, ActiveSheet.Range(DelStr_Cut(i)))
End If
Next i
Thanks,
Bakul

Related

EXCEL VBA to deal amount data , how to filter data and copy paste to another sheet faster?

I have an CVS file that have amount of data over hundred thousands.
Because the data file have many space not regular, I used filter "space" to filter one by one columns. After filter, I copy this column and paste to another sheet. I do those steps until the column data end.
My file have many columns and hundreds thousand rows, but after filter "space" that about 100 thousands.
But now I had a problem, I had wait too long about 5 minutes to finish this wrok.
How could I run faster?
I try to use Selection.SpecialCells(xlCellTypeVisible).Copy, took more time.
Thanks!
Below is my excel VBA filter space and copy paste code
Sub FilterData()
On Error GoTo ErrorHandler
Dim AddSheetName As String
Dim CSVNoExtensionName As String
Dim LastColumn As Long
Dim FinalRow As Variant
Dim idxDataCol, idxPasteCol As Integer
Dim sDelayTime As String
sDelayTime = "02"
AddSheetName = "sheet1"
Dim Time0#
Time0 = Timer
Workbooks(CSVDataFileName).Activate
If InStr(CSVDataFileName, ".") > 0 Then
CSVNoExtensionName = Left(CSVDataFileName, InStr(CSVDataFileName, ".") - 1)
End If
Sheets.Add(After:=ActiveSheet).Name = AddSheetName
Worksheets(CSVNoExtensionName).Activate
LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
FinalRow = Range("A1").End(xlDown).Row
idxPasteCol = 1
For idxDataCol = 2 To LastColumn Step 1
Cells(1, idxDataCol).Select
Selection.AutoFilter
ActiveSheet.Range(Cells(1, 1), Cells(FinalRow, LastColumn)).AutoFilter Field:=idxDataCol, Criteria1:="<>"
Dim rng1, rng2 As Range
Set rnge2 = Range(Cells(1, idxDataCol), Cells(FinalRow, idxDataCol))
Set rng1 = Union(Range("A1:A" & FinalRow), rnge2)
rng1.Select
Selection.Copy
Application.Wait (Now + TimeValue("0:00:" & sDelayTime))
Sheets(AddSheetName).Select
ActiveSheet.Cells(1, idxPasteCol).Select
ActiveSheet.Paste
Columns(idxPasteCol).Font.ColorIndex = 41
Sheets(CSVNoExtensionName).Select
Application.CutCopyMode = False
Selection.AutoFilter
idxPasteCol = idxPasteCol + 2
Next idxDataCol
ActiveSheet.Cells(1, 1).Select
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:=CSVNoExtensionName & ".xlsx", FileFormat:=xlOpenXMLStrictWorkbook, CreateBackup:=False
Exit Sub
End Sub
Couldn't clearly understand, how you want to filter "space". Assumption (from code) that objective is to filter out any lines containing Blank or Blank space, I would like to do it directly reading from and writing to text file.
Moreover if the assumption is correct, the commands Select, Activate etc within the code increase operating time. Also operating in loop for each column is fine, but think union range method is unnecessary. After applying filter to all the columns the whole data area could be copied and pasted. But that may also widen up possibility of 1004 Error "Ms excel cannot create or use data range reference because it is too complex" as here data to be dealt with is more than 100 K.
So i tried with a data over 150 K rows X 50 columns directly, It takes 20 odd seconds to process the data as text file and another 20 seconds to open the resulted CSV file and save it as xlsx. The File format used in code is giving some problem (at least in Excel 2007) so i saved it directly as xlsx.
Sub test()
Dim oFlNo As Integer, iFlNo As Integer
Dim oFlName As String, iFlName As String
Dim oFolder As String, iFolder As String
Dim Arr As Variant, HaveBlank As Boolean
Dim Tm As Double
Tm = Timer
iFlName = "C:\users\user\desktop\FilerCSv.Csv"
oFlName = "C:\users\user\desktop\FilteredCSv.Csv"
iFlNo = FreeFile
Open iFlName For Input As #iFlNo
oFlNo = FreeFile
Open oFlName For Output As #oFlNo
Do While Not EOF(iFlNo) ' Loop until end of file.
Line Input #iFlNo, Ln ' Read line into variable.
Arr = Split(Ln, ",")
HaveBlank = False
For Each xVal In Arr
xVal = Trim(xVal)
If xVal = "" Then
HaveBlank = True
Exit For
End If
Next
If HaveBlank = False Then
Write #oFlNo, Ln
End If
Loop
Close #iFlNo
Close #oFlNo
Debug.Print Timer - Tm
Workbooks.Open (oFlName)
oFlName = Left(oFlName, Len(oFlName) - 4)
ActiveWorkbook.SaveAs Filename:=oFlName & ".xlsx" ', FileFormat:=xlOpenXMLStrictWorkbook, CreateBackup:=False
Debug.Print Timer - Tm
End Sub
Since I personally don't prefer to keep calculations, event processing and screen updating off (in normal cases) i haven't added that standard lines. However you may use these standard techniques on your discretion.

Hide table rows *unless* any of 3 columns (in that row) are not blank

I've built this code, and it's working fine. However I expect there must be a more elegant way to embed the range 'c' into the Evaluate function rather than how I've used 'r' to determine the row number, and build that into the reference.
(I'm learning). Copy of (very stripped down) xlsm available here: https://www.dropbox.com/s/e6pcugqs4zizfgn/2018-11-28%20-%20Hide%20table%20rows.xlsm?dl=0
Sub HideTableRows()
Application.ScreenUpdating = False
Dim c As Range
Dim r As Integer
For Each c In Range("ForecastTable[[Group]:[Item]]").Rows
r = c.Row
If Application.Evaluate("=COUNTA(B" & r & ":D" & r & ") = 0") = True Then
c.EntireRow.Hidden = True
Else: c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
There's no specific question/problem, but here's my suggested code improvements.
Most notably, I wouldn't execute the Hidden procedure until you have all the rows. That way you don't have repeatedly do something that only need be completed once. This will always be the best practice when looping and manipulating data. Make changes to the sheet AFTER you have identified the range.
With the above change, you don't need to turn off ScreenUpdating.
The Evaluate function is fine, but isEmpty is probably the best option. There are probably slightly faster methods, perhaps checking multiple if-statements, but that's getting into fractions of a second over thousands of rows (probably not worth researching).
Technically you don't really need to loop by rows. You can get by with a single cell in a row, then checking the next two over, see utilization of Offset to generate that range. This also creates a more dynamic than using hard-coded columns ("A"/"B"...etc")
Long is recommended over Integer but this is pretty small, and I'm only mentioning it because I posted about it here.. Technically you don't even need it with the above changes.
Here's the code:
Sub HideTableRows()
Dim c As Range, hIdeRNG As Range, WS As Worksheet
'based on OP xlsm file.
Set WS = Sheet4
'used range outside of used range to avoid an if-statement on every row
Set hIdeRNG = WS.Cells(Rows.Count, 1)
'loops through range of single cells for faster speed
For Each c In Range("ForecastTable[Group]").Cells
If IsEmpty(Range(c, c.Offset(0, 2))) = 0 Then
'only need a single member in the row.
Set hIdeRNG = Union(hIdeRNG, c)
End If
Next c
'Hides rows only if found more than 1 cell in loop
If hIdeRNG.Cells.Count > 1 Then
Intersect(WS.UsedRange, hIdeRNG).EntireRow.Hidden = True
End If
End Sub
Final Thought: There's some major enhancements coming out to Excel supposedly in early 2019 that might be useful for this type of situation if you were looking for a non-VBA solution. Click here for more info from MS.
Flipping the logic a bit, why not just filter those three columns for blanks, then hide all the visible filtered blank rows in one go?
Something like this:
Sub DoTheHide()
Dim myTable As ListObject
Set myTable = Sheet4.ListObjects("ForecastTable")
With myTable.Range
.AutoFilter Field:=1, Criteria1:="="
.AutoFilter Field:=2, Criteria1:="="
.AutoFilter Field:=3, Criteria1:="="
End With
Dim rowsToHide As Range
On Error Resume Next
Set rowsToHide = myTable.DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
myTable.AutoFilter.ShowAllData
If Not rowsToHide Is Nothing Then
rowsToHide.EntireRow.Hidden = True
End If
End Sub
Since c is used to iterate over the rows and each row contains the 3 cells in question ("=COUNTA(B" & r & ":D" & r & ") = 0") is equivalent to ("=COUNTA(" & c.Address & ") = 0"). But using the WorksheetFunction directly is a better appraoch.
It should be noted that Range("[Table]") will return the proper result as long as the table is in the ActiveWorkbook. It would be better to useThisWorkbook.Worksheets("Sheet1").Range("[Table]")`.
Sub HideTableRows()
Application.ScreenUpdating = False
Dim row As Range, target As Range
With Range("ForecastTable[[Group]:[Item]]")
.EntireRow.Hidden = False
For Each row In .rows
If Application.WorksheetFunction.CountA(row) = 0 Then
If target Is Nothing Then
Set target = row
Else
Set target = Union(target, row)
End If
End If
Next
End With
If Not target Is Nothing Then target.EntireRow.Hidden = True
Application.ScreenUpdating = True
End Sub

Excel VBA Store row numbers in Array and delete multiple rows at once

I'm trying to delete all rows on my worksheet that have a unique value in column B.
I know this can be done with a filter or conditioned formatting, but I would like to know if the following is possible as well, since it could be useful in other situations:
I want to loop through all rows and store the row number in an Array if the row has a unique value in column B. Then delete all the rows whose number is stored in the Array in one single action.
The reasoning for storing the row numbers in an Array instead of deleting the desired rows in the loop is to reduce runtime.
My data varies in number of rows but is always in column A:K and it always begins on row 6.
Below is the code I've written with inspiration from the following links:
Dynamically adding values to the array on the go.
Deleting rows whose number is stored in array in one single action (see Tim Williams answer).
I get the error message: Run-time error '5': Invalid procedure call or Argument
Sub DeleteRows()
Dim ws4 As Worksheet: Set ws4 = Worksheets("Sheet1")
Dim LastRow As Long
Dim CurrentRow As Long
Dim GroupValue
Dim GroupTotal As Long
Dim MyArray()
Dim y As Long
Application.ScreenUpdating = False
ws4.Activate
GroupValue = ws4.Range("B6").Value ' Sets the first GroupValue
CurrentRow = 6 ' Sets the starting row
y = 0
LastRow = ws4.Cells(Rows.Count, "B").End(xlUp).Row
For x = 1 To LastRow
GroupTotal=Application.WorksheetFunction.CountIf(Range("B6:B"&LastRow), _
GroupValue) ' Searches for the GroupValue and finds number of matches
If GroupTotal = 1 Then ' If GroupTotal = 1 then add the row# to the array
ReDim Preserve MyArray(y)
MyArray(y) = CurrentRow
y = y + 1
End If
CurrentRow = CurrentRow + GroupTotal 'set the next row to work with
GroupValue = Range("B" & CurrentRow).Value 'set next GroupValue to find
If GroupValue = "" Then ' Checks to see if the loop can stop
Exit For
End If
Next x
'***This should delete all the desired rows but instead produces the error.***
ws4.Range("B" & Join(MyArray, ",B")).EntireRow.Delete
Application.ScreenUpdating = True
End Sub
I've researched for hours and tried to manipulate the code with no luck.
Use a variable defined as a Range and Union each row to it.
In the example below MyArray is the array of row numbers that should be deleted.
Public Sub Test()
Dim MyArray() As Variant
MyArray = Array(2, 4, 5, 8, 10, 15)
DeleteRows MyArray
End Sub
Public Sub DeleteRows(RowNumbers As Variant, Optional SheetName As String = "")
Dim wrkSht As Worksheet
Dim rRange As Range
Dim x As Long
On Error GoTo ERROR_HANDLER
If SheetName = "" Then
Set wrkSht = ActiveSheet
Else
Set wrkSht = ThisWorkbook.Worksheets(SheetName)
End If
For x = LBound(RowNumbers) To UBound(RowNumbers)
If rRange Is Nothing Then
Set rRange = wrkSht.Rows(RowNumbers(x))
Else
Set rRange = Union(rRange, wrkSht.Rows(RowNumbers(x)))
End If
Next x
If Not rRange Is Nothing Then rRange.Delete
On Error GoTo 0
Exit Sub
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure DeleteColumns."
Err.Clear
Application.EnableEvents = True
End Select
End Sub
Edit
The Test procedure can be replaced with any code that creates an array of row numbers. The array is then passed to the DeleteRows procedure. You could also pass it a sheet name to delete the rows from: DeleteRows MyArray, "Sheet2".
The DeleteRows procedure sets up the variables, turns error checking on and then checks if a sheet name was passed to it. It then sets a reference to either the active sheet or the named sheet. You could also check if the passed sheet actually exists here.
Next a loop starts going from the first to last element of the array. The first is usually 0 so you could replace LBOUND(RowNumbers) with 0.
rRange is the variable that's going to hold the row references to delete and Union won't work if it doesn't already hold a range reference.
On the first pass of the loop it won't hold a reference so will be nothing and the first row in the array will be set as the first row reference on the sheet held in wrkSht.
On subsequent passes rRange will already hold a reference so the next row will be unioned to it.
Those two decisions are made in an IF...END IF block seperated by an ELSE statement.
After the loop has finished a single line IF statement - no END IF required on single line - checks if rRange holds any references. If it does then those rows are deleted.
The procedure exits the main body of code, deals with the error handling and then ends.

Reorganizing an Excel Sheet, one column into many columns [duplicate]

This question already has answers here:
Aggregate, Collate and Transpose rows into columns
(3 answers)
Closed 6 years ago.
I'm pretty new to stack overflow but I've been on here as a lurker before.
So I'm having trouble reorganizing this excel output. The original output is below. I've modified the output to preserve the confidentiality of the dataset and also in the interest of time as the dataset has over 10k cells, but the ideas should be clear.
Before
As you can see, there's a lot of duplicates and useless stuff and in general annoying bits. Basically I need to reorganize the data into column headers and repopulate the spreadsheet so that the data stays with the proper code number. The current column headers of supercatagory and subcategory are worthless. I've attached what I think would be the ideal here. After
I've tried using pivot tables and that kind of serves as a half measure but that would still require me to go through the output and copy and paste by hand for over 2 hours. I've also tried using transpose in excel and while that is good for the first part of the problem, making new column headers, but it doesn't solve the problem of repopulating the spreadsheet and keeping everything straight.
Thank you so much.
Without knowing more, the below code works for me in testing with the data provided in your images. The big question of course is where the column headers in the After data came from. It appeared to come from column B of the Before data. I assumed these would be duplicated for each unique value from column A. As such, in the below code, only the first set of values is used to set the headers of the newly created sheet.
Option Explicit
Sub TransposeWithUniques()
Dim SourceSheet As Worksheet
Dim TargetSheet As Worksheet
Dim Uniques As Collection
Dim Unique As Variant
Dim UniqueData() As Variant
Dim FormulaColumn As Range
Dim CriteriaColumn As Range
Dim DataRange As Range
Dim FoundRange As Range
Dim ValueIndex As Long
Dim LastRow As Long
Dim LastColumn As Long
Dim NewRow As Long
Dim ErrorFound As Boolean
Set SourceSheet = ActiveSheet '!!! This will need to be the currently active sheet housing your data
' If sheet is protected, exit
If SourceSheet.ProtectContents Then
MsgBox "Please unprotect the worksheet first.", vbExclamation, "Transpose with Uniques"
Exit Sub
End If
' Get last row/column
LastRow = SourceSheet.Cells(SourceSheet.Rows.Count, 1).End(xlUp).Row
LastColumn = SourceSheet.Cells(1, SourceSheet.Columns.Count).End(xlToLeft).Column
Set DataRange = SourceSheet.Range("A1", SourceSheet.Cells(LastRow, LastColumn))
NewRow = 1
' Get unique UniqueData from column A
UniqueData = SourceSheet.Range("A2:A" & LastRow).Value2
Set Uniques = New Collection
For ValueIndex = LBound(UniqueData, 1) To UBound(UniqueData, 1)
If InCollection(Uniques, CStr(UniqueData(ValueIndex, 1))) = False Then
Uniques.Add UniqueData(ValueIndex, 1), CStr(UniqueData(ValueIndex, 1))
End If
Next ValueIndex
' Set application properties for better code running experience
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
' Add helper columns
On Error GoTo TransposeWithUniques_Error
SourceSheet.Cells(1, LastColumn).Offset(0, 1).Resize(LastRow, 2).Insert
Set CriteriaColumn = SourceSheet.Cells(1, LastColumn).Offset(0, 1).Resize(LastRow, 1)
Set FormulaColumn = SourceSheet.Cells(1, LastColumn).Offset(0, 2).Resize(LastRow, 1)
FormulaColumn(1, 1).Value = "FORMULA"
CriteriaColumn(1, 1).Value = "CRITERIA"
FormulaColumn(2, 1).Resize(LastRow - 1, 1).Formula = "=ROW(A1)"
FormulaColumn(2, 1).Resize(LastRow - 1, 1).Value = FormulaColumn(2, 1).Resize(LastRow - 1, 1).Value
' Loop through all uniques, get data and move it
For Each Unique In Uniques
CriteriaColumn(2, 1).Resize(LastRow - 1, 1).Formula = "=1/(A2=" & Chr(34) & Unique & Chr(34) & ")"
CriteriaColumn(2, 1).Resize(LastRow - 1, 1).Value = CriteriaColumn(2, 1).Resize(LastRow - 1, 1).Value
DataRange.Resize(, DataRange.Columns.Count + 2).Sort Key1:=CriteriaColumn(1, 1), Order1:=xlAscending, Key2:=SourceSheet.Range("B1"), Order2:=xlAscending, Header:=xlYes
On Error Resume Next
Set FoundRange = CriteriaColumn.SpecialCells(xlCellTypeConstants, xlNumbers)
On Error GoTo 0
If Not FoundRange Is Nothing Then
If TargetSheet Is Nothing Then
Set TargetSheet = ActiveWorkbook.Worksheets.Add(After:=SourceSheet)
TargetSheet.Range("A1").Value = SourceSheet.Range("A1").Value
TargetSheet.Range("B1").Resize(1, FoundRange.Cells.Count).Value = Application.Transpose(Intersect(SourceSheet.Range("B:B"), FoundRange.EntireRow).Value)
End If
NewRow = NewRow + 1
TargetSheet.Cells(NewRow, 1).Value = Unique
TargetSheet.Cells(NewRow, 2).Resize(1, FoundRange.Cells.Count).Value = Application.Transpose(Intersect(SourceSheet.Range("C:C"), FoundRange.EntireRow).Value)
Set FoundRange = Nothing
End If
Next Unique
' Reset data to original state
DataRange.Resize(, DataRange.Columns.Count + 2).Sort Key1:=FormulaColumn(1, 1), Order1:=xlAscending, Header:=xlYes
FormulaColumn.Delete xlToLeft
CriteriaColumn.Delete xlToLeft
TransposeWithUniques_Exit:
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
If Not ErrorFound Then
MsgBox "Process completed successfully.", vbInformation, "Transpose with Uniques"
End If
Exit Sub
TransposeWithUniques_Error:
ErrorFound = True
MsgBox "Something went wrong.", vbExclamation, "Transpose with Uniques"
GoTo TransposeWithUniques_Exit
End Sub
Public Function InCollection(CheckCollection As Collection, CheckKey As String) As Boolean
'
' Returns True if the specified key is found in the specified collection.
'
' Syntax: InCollection(CheckCollection,CheckKey)
'
' Parameters: CheckCollection. Collection. Required. The collection to search in.
' CheckKey. String. Required. The string key to search in collection for.
'
On Error Resume Next
InCollection = CBool(Not IsEmpty(CheckCollection(CheckKey)))
On Error GoTo 0
End Function
To use the above code, in your file you want to run this on, press ALT+F11 to open the Visual Basic Editor (VBE). Press CTRL+R to show the Project Explorer (PE), generally this shows by default. Find your project in the PE and right-click it, select Insert, Module. Double click the newly inserted module (should be named Module1). Copy/paste the above code into this module. Click anywhere inside the top routine (for example, click on the text near the top "TransposeWithUniques" so your cursor is on that line, or just below it). Press F5 to run the routine.
CAUTION: Make sure you save a backup copy of your file prior to running this. It resets the data to its original state, but this is always good practice. Check the newly created sheet to ensure it's what you're looking for. If this isn't what you're looking for, please be as specific as possible in explaining the input versus output.
Regards,
Zack Barresse

Clear cells in a column of values if it has strings

Im trying to write / find a macro that when ran removes the value in a cell if the cells in the column is not a number. IE remove all the cells in column B if a string is found. I have this script to delete empty rows.
Was just trying to re write it so that it can delete the rows based on these condiitions
Sub RemoveRows()
Dim lastrow As Long
Dim ISEmpty As Long
lastrow = Application.CountA(Range("A:XFD"))
Range("A1").Select
Do While ActiveCell.Row < lastrow
ISEmpty = Application.CountA(ActiveCell.EntireRow)
If ISEmpty = 0 Then
ActiveCell.EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
End Sub
The code iterates backward from the last cell in column B and checks if the value in the cell is numeric using the IsNumeric() function.
If the value is not numeric then it deletes the entire row.
Note: looping backwards (ie. from the last row to first) is necessary when using a loop because the index gets shifted everytime a row gets deleted. Therefore, to avoid skipping some rows backward iteration is required.
Sub KeepOnlyNumbers()
Application.ScreenUpdating = False
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
Dim i As Long
' iterating backwards (from last row to first to keep the logic flow)
For i = ws.Range("B" & ws.Rows.Count).End(xlUp).Row To 1 Step -1
' check whether the value is numeric
If Not IsNumeric(Range("B" & i)) Then
' if not numeric then clear the cells content
Range("B" & i).ClearContents
End If
Next i
Application.ScreenUpdating = True
End Sub
You can use IsNumeric to evaluate if an object can be evaluated as a number. So you can add:
If Not IsNumeric(ActiveCell) Then
ActiveCell.EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If
to your Do While loop and it should do what you want. I haven't tested this; let me know if you get an error.
You do not have to iterate backwards even when deleting rows, you can do union and call delete/clear on the unioned range.
Sub UnionOnCondition()
Dim usedColumnB
Set usedColumnB = Intersect(ActiveSheet.UsedRange, _
ActiveSheet.Columns("b"))
If usedColumnB Is Nothing Then _
Exit Sub
Dim result: Set result = Nothing
Dim cellObject
For Each cellObject In usedColumnB
' skip blanks, formulas, dates, numbers
If cellObject = "" Or _
cellObject.HasFormula Or _
IsDate(cellObject) Or _
IsNumeric(cellObject) Then GoTo continue
If result Is Nothing Then
Set result = cellObject.EntireRow
Else
Set result = Union(result, cellObject.EntireRow)
End If
continue:
Next
If Not result Is Nothing Then _
result.Select ' result.Clear or result.Delete
End Sub

Resources