I have a couple thousand rows in a workbook.
There are several hundred rows that are blank.
How can I remove every entirely blank row?
There are two ways to do that:
1. With VBA:
There is a VBA script here in this link. Use the first script, I mean DeleteBlankRows.
You can also copy the same code from here.
How to use:
Copy the code.
In Excel press Alt + F11 to enter the VBE.
Press Ctrl + R to show the Project Explorer.
Insert -> Module.
Paste code.
Save and Exit VBE.
Run the code:
Select the column with blank rows.
Press Alt + F8 to open the macro dialog box.
Select DeleteBlankRows
Click Run.
2. Without VBA:
Just check the link here. It is easy so no need to explain again here.
I'll paste the code here just in case the link dies in the future.
Just a note, the second part "Without VBA" will NOT meet the requirements of the original questions because it will delete rows that contain blank cells, but are not COMPLETELY blank.
Here's the code from the first link of the accepted answer.
Sub DeleteBlankRows(Optional WorksheetName As Variant)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DeleteBlankRows
' This function will delete all blank rows on the worksheet
' named by WorksheetName. This will delete rows that are
' completely blank (every cell = vbNullString) or that have
' cells that contain only an apostrophe (special Text control
' character).
' The code will look at each cell that contains a formula,
' then look at the precedents of that formula, and will not
' delete rows that are a precedent to a formula. This will
' prevent deleting precedents of a formula where those
' precedents are in lower numbered rows than the formula
' (e.g., formula in A10 references A1:A5). If a formula
' references cell that are below (higher row number) the
' last used row (e.g, formula in A10 reference A20:A30 and
' last used row is A15), the refences in the formula will
' be changed due to the deletion of rows above the formula.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim RefColl As Collection
Dim RowNum As Long
Dim Prec As Range
Dim Rng As Range
Dim DeleteRange As Range
Dim LastRow As Long
Dim FormulaCells As Range
Dim Test As Long
Dim WS As Worksheet
Dim PrecCell As Range
If IsMissing(WorksheetName) = True Then
Set WS = ActiveSheet
Else
On Error Resume Next
Set WS = ActiveWorkbook.Worksheets(WorksheetName)
If Err.Number <> 0 Then
'''''''''''''''''''''''''''''''
' Invalid worksheet name.
'''''''''''''''''''''''''''''''
Exit Sub
End If
End If
If Application.WorksheetFunction.CountA(WS.UsedRange.Cells) = 0 Then
''''''''''''''''''''''''''''''
' Worksheet is blank. Get Out.
''''''''''''''''''''''''''''''
Exit Sub
End If
''''''''''''''''''''''''''''''''''''''
' Find the last used cell on the
' worksheet.
''''''''''''''''''''''''''''''''''''''
Set Rng = WS.Cells.Find(what:="*", after:=WS.Cells(WS.Rows.Count, WS.Columns.Count), lookat:=xlPart, _
searchorder:=xlByColumns, searchdirection:=xlPrevious, MatchCase:=False)
LastRow = Rng.Row
Set RefColl = New Collection
'''''''''''''''''''''''''''''''''''''
' We go from bottom to top to keep
' the references intact, preventing
' #REF errors.
'''''''''''''''''''''''''''''''''''''
For RowNum = LastRow To 1 Step -1
Set FormulaCells = Nothing
If Application.WorksheetFunction.CountA(WS.Rows(RowNum)) = 0 Then
''''''''''''''''''''''''''''''''''''
' There are no non-blank cells in
' row R. See if R is in the RefColl
' reference Collection. If not,
' add row R to the DeleteRange.
''''''''''''''''''''''''''''''''''''
On Error Resume Next
Test = RefColl(CStr(RowNum))
If Err.Number <> 0 Then
''''''''''''''''''''''''''
' R is not in the RefColl
' collection. Add it to
' the DeleteRange variable.
''''''''''''''''''''''''''
If DeleteRange Is Nothing Then
Set DeleteRange = WS.Rows(RowNum)
Else
Set DeleteRange = Application.Union(DeleteRange, WS.Rows(RowNum))
End If
Else
''''''''''''''''''''''''''
' R is in the collection.
' Do nothing.
''''''''''''''''''''''''''
End If
On Error GoTo 0
Err.Clear
Else
'''''''''''''''''''''''''''''''''''''
' CountA > 0. Find the cells
' containing formula, and for
' each cell with a formula, find
' its precedents. Add the row number
' of each precedent to the RefColl
' collection.
'''''''''''''''''''''''''''''''''''''
If IsRowClear(RowNum:=RowNum) = True Then
'''''''''''''''''''''''''''''''''
' Row contains nothing but blank
' cells or cells with only an
' apostrophe. Cells that contain
' only an apostrophe are counted
' by CountA, so we use IsRowClear
' to test for only apostrophes.
' Test if this row is in the
' RefColl collection. If it is
' not in the collection, add it
' to the DeleteRange.
'''''''''''''''''''''''''''''''''
On Error Resume Next
Test = RefColl(CStr(RowNum))
If Err.Number = 0 Then
''''''''''''''''''''''''''''''''''''''
' Row exists in RefColl. That means
' a formula is referencing this row.
' Do not delete the row.
''''''''''''''''''''''''''''''''''''''
Else
If DeleteRange Is Nothing Then
Set DeleteRange = WS.Rows(RowNum)
Else
Set DeleteRange = Application.Union(DeleteRange, WS.Rows(RowNum))
End If
End If
Else
On Error Resume Next
Set FormulaCells = Nothing
Set FormulaCells = WS.Rows(RowNum).SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If FormulaCells Is Nothing Then
'''''''''''''''''''''''''
' No formulas found. Do
' nothing.
'''''''''''''''''''''''''
Else
'''''''''''''''''''''''''''''''''''''''''''''''''''
' Formulas found. Loop through the formula
' cells, and for each cell, find its precedents
' and add the row number of each precedent cell
' to the RefColl collection.
'''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
For Each Rng In FormulaCells.Cells
For Each Prec In Rng.Precedents.Cells
RefColl.Add Item:=Prec.Row, key:=CStr(Prec.Row)
Next Prec
Next Rng
On Error GoTo 0
End If
End If
End If
'''''''''''''''''''''''''
' Go to the next row,
' moving upwards.
'''''''''''''''''''''''''
Next RowNum
''''''''''''''''''''''''''''''''''''''''''
' If we have rows to delete, delete them.
''''''''''''''''''''''''''''''''''''''''''
If Not DeleteRange Is Nothing Then
DeleteRange.EntireRow.Delete shift:=xlShiftUp
End If
End Sub
Function IsRowClear(RowNum As Long) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''
' IsRowClear
' This procedure returns True if all the cells
' in the row specified by RowNum as empty or
' contains only a "'" character. It returns False
' if the row contains only data or formulas.
''''''''''''''''''''''''''''''''''''''''''''''''''
Dim ColNdx As Long
Dim Rng As Range
ColNdx = 1
Set Rng = Cells(RowNum, ColNdx)
Do Until ColNdx = Columns.Count
If (Rng.HasFormula = True) Or (Rng.Value <> vbNullString) Then
IsRowClear = False
Exit Function
End If
Set Rng = Cells(RowNum, ColNdx).End(xlToRight)
ColNdx = Rng.Column
Loop
IsRowClear = True
End Function
I found current answer unnecessarily long.
My code below is checking all used range rows one by one and if they are blank - it deletes them.
Public Sub DeleteEmptyRows()
Dim SourceRange As Range
Dim EntireRow As Range
On Error Resume Next
Set SourceRange = Sheet1.UsedRange
If Not (SourceRange Is Nothing) Then
Application.ScreenUpdating = False
For i = SourceRange.Rows.Count To 1 Step -1
Set EntireRow = SourceRange.Cells(i, 1).EntireRow
If Application.WorksheetFunction.CountA(EntireRow) = 0 Then
EntireRow.Delete
End If
Next
Application.ScreenUpdating = True
End If
End Sub
Related
Hello I am wondering if anyone has any suggestions for a replacement for a Do Until loop in VBA??
My Code (see below), basically looks at cell F4, if Cell F4 is 0 then the row is selected and deleted. the cells then shift up, it loops again until the F4 is either greater than zero or it is empty.
The code actually works perfectly well but it takes an age to finish (around 3 mins at a guess). I do make sure that screen updating is turned off etc, I just haven't included that in this example.
I am not to fussed that it takes so long in the first instance but eventually it will doing this search multiple times in one hit, potentially up to 10K cells at a time so I want it to be a bit more snappy...
So my question is is there anything I can do other than Do until loops?
Do Until Raw1.Range("F4") = "" Or Raw1.Range("F4") > 0
If Raw1.Range("F4").Value = 0 Then
Raw1.Range("A4:H4").Select
Selection.Delete Shift:=xlUp
End If
Loop
Delete Data Using AutoFilter
Starting from row 4 (the header row is 3), this will delete all consecutive A:H row ranges, whose cell values in column F are equal to 0 (preserving blank cells).
Option Explicit
Sub DeleteZeros()
' 'Raw1' is the code name of a worksheet in the workbook containing this code.
Const FirstCellAddress As String = "F3"
Const ColumnsAddress As String = "A:H"
If Raw1.FilterMode Then Raw1.ShowAllData
Dim crg As Range ' Column Range (Has Headers - 'F')
With Raw1.Range(FirstCellAddress)
Dim lRow As Long
lRow = Raw1.Cells(Raw1.Rows.Count, .Column).End(xlUp).Row
Dim rCount As Long: rCount = lRow - .Row + 1
If rCount < 2 Then Exit Sub ' to few rows
Set crg = .Resize(rCount)
End With
Dim drg As Range ' Data Range (No Headers - 'A:H')
With crg
Set drg = .Resize(rCount - 1).Offset(1) _
.EntireRow.Columns(ColumnsAddress)
End With
Dim FirstDataRow As Long: FirstDataRow = drg.Row
' Filter Column Range
crg.AutoFilter 1, "0"
Dim vdrg As Range ' Visible Data Range (No Headers - 'A:H')
On Error Resume Next
Set vdrg = drg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
Raw1.AutoFilterMode = False
' Delete
If vdrg Is Nothing Then Exit Sub
If vdrg.Cells(1).Row <> FirstDataRow Then Exit Sub
vdrg.Areas(1).Delete xlShiftUp
End Sub
It is always a better solution to delete from bottom up then from top down.
Sub deleteRows()
Const checkColumn As Long = 6 'Column F
Dim rg As Range
'!!!!!you will have to adjust this to your needs!!!!
Set rg = ActiveSheet.Cells(checkColumn, 4).CurrentRegion
Dim cntRows As Long
cntRows = rg.Rows.Count
Dim i As Long
For i = cntRows To 1 Step -1
If rg.Cells(i, checkColumn) = 0 Then
'rg.Rows(i).EntireRow.Delete xlShiftUp 'removes entire row
rg.Rows(i).Delete xlShiftUp 'removes only columns A-H
End If
Next
End Sub
It is faster to delete all the cells in 1 operation. In my example code, I have a runner find the last valid cell. I use that cell to determine the size of range that needs to be deleted.
Sub RemoveEmptyRowsBasedOnColumnValues()
Dim CalculationMode As XlCalculation
CalculationMode = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim Cell As Range
With Raw1
For Each Cell In .Range("F4", .Cells(.Rows.count, "F").End(xlUp))
If Cell.Value > 0 Then
If Cell.Row > 3 Then
.Range("A4:H4").Resize(Cell.Row - 4).Delete Shift:=xlUp
End If
Exit For
End If
Next
End With
Application.Calculation = CalculationMode
End Sub
Function Raw1() As Worksheet
Set Raw1 = ThisWorkbook.Worksheets("Raw1")
End Function
Look for (HERE) in below code for line I'm talking about.
Is it possible to setup an error message if it doesn't find any criteria "Active" in Column D?
I tried inputting an on error goto but it gave the msgbox when there were no "Active" projects in column D. But as soon as there was an "Active" Cell it would error out and not finish the code.
I did use a Exit Sub and Resume but still didn't work.
Const cCrit As Variant = "D" ' Criteria Column Letter/Number
Const cCols As String = "C:J" ' Source/Target Data Columns
Const cFRsrc As Long = 15 ' Source First Row
Dim ws1 As Worksheet ' Source Workbook
Dim ws2 As Worksheet ' Target Workbook
Dim rng As Range ' Filter Range, Copy Range
Dim lRow As Long ' Last Row Number
Dim FRtgt As Long ' Target First Row
Dim Answer As VbMsgBoxResult ' Message Box
Dim Error1 As VbMsgBoxResult ' Message Box for Errors
' Create references to worksheets.
With ThisWorkbook
Set ws1 = .Worksheets("Future Project Hopper")
Set ws2 = .Worksheets("CPD-Carryover,Complete&Active")
End With
Answer = MsgBox("Do you want to run the Macro?", vbYesNo, "Run Macro")
If Answer <> vbYes Then Exit Sub
' In Source Worksheet
With ws1
' Clear any filters.
.AutoFilterMode = False
' Calculate Last Row.
lRow = .Cells(.Rows.Count, cCrit).End(xlUp).row
' Calculate Filter Column Range.
Set rng = .Cells(cFRsrc, cCrit).Resize(lRow - cFRsrc + 1)
' Make an offset for the filter to start a row before (above) and
' end a row after (below).
With rng.Offset(-1).Resize(lRow - cFRsrc + 3)
' Filter data in Criteria Column.
.AutoFilter Field:=1, Criteria1:="Active"
End With
' Create a reference to the Copy Range.
**(HERE)** Set rng = .Columns(cCols).Resize(rng.Rows.Count).Offset(cFRsrc - 1) _
.SpecialCells(xlCellTypeVisible)
' Clear remaining filters.
.AutoFilterMode = False
End With
' Calculate Target First Row.
FRtgt = ws2.Cells(ws2.Rows.Count, cCrit).End(xlUp).row + 1
' Copy Range and paste to Target Worksheet and clear contents of future project hopper
rng.Copy
ws2.Columns(cCols).Resize(1).Offset(FRtgt - 1).PasteSpecial xlPasteValues
rng.Rows.ClearContents
Application.CutCopyMode = False
Give this a shot:
On Error Resume Next
Set Rng = .Columns(cCols).Resize(Rng.Rows.Count).Offset(cFRsrc - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Rng Is Nothing Then
MsgBox "No criteria found! Exiting sub"
Exit Sub
End If
I want to hide the blank columns on multiple sheets. I can do it on just the active sheet but when I try to make it so it applies to all sheets with a month in the name it doesn't work. This is what I have so far:
Sub CommandButton1_Click()
Dim col As Range
Dim sheetsArray As Sheets
Set sheetsArray = ActiveWorkbook.Sheets(Array("*Jan*", "*Feb*", "*Mar*", "*Apr*", "*May*", "*Jun*", "*Jul*", "*Aug*", "*Sep*", "*Oct*", "*Nov*", "*Dec*"))
Dim sheet As Worksheet
Application.ScreenUpdating = False
For Each sheet In sheetsArray
sheet.Columns.Hidden = False
For Each col In sheet.UsedRange.Columns
col.Hidden = sheet.col.Cells(Rows.Count, 1).End(xlUp).Row = 1
Next col
Next sheet
Application.ScreenUpdating = True
End Sub
It's also now giving me a "Method or Data member not found error"
The Worksheet class does not have a method or data member named col. You can remove sheet. in front of col. Also, at the top of your module, add Option Explicit; then, before running your code, click the Debug menu and then Compile in order to catch such issues early on.
Other than that, you will have to check each sheet name against your name filters; the ActiveWorkbook.Sheets collection unfortunately won't magically interpret the filters in your array. In the end, you can go along those lines:
Option Explicit
Sub CommandButton1_Click()
Dim sheet As Worksheet
Dim col As Range
Dim sheetNameFilters As Variant
Dim filter As Variant
sheetNameFilters = Array("*Jan*", "*Feb*", "*Mar*", "*Apr*", "*May*", "*Jun*", "*Jul*", "*Aug*", "*Sep*", "*Oct*", "*Nov*", "*Dec*")
Application.ScreenUpdating = False
For Each sheet In ThisWorkbook.Worksheets
For Each filter In sheetNameFilters
If sheet.Name Like filter Then
sheet.Columns.Hidden = False
For Each col In sheet.UsedRange.Columns
col.Hidden = (col.Cells(Rows.Count, 1).End(xlUp).Row = 1)
Next
Exit For
End If
Next
Next
Application.ScreenUpdating = True
End Sub
I'm not sure if Array can perform the wild card search as you intended to. Like is a function that can be used as shown in the code below. Hope it meets your needs
Sub HideColumns()
Dim col As Range
Dim sheet As Worksheet
Application.ScreenUpdating = False
For Each sheet In ThisWorkbook.Worksheets
'check if worksheet name as month in it
If sheet.Name Like "*Jan*" Or sheet.Name Like "*Feb*" Or sheet.Name Like "*Mar*" Then 'add for rest of the months
sheet.Columns.Hidden = False 'make all columns visible
DoEvents
'reset the user range
sheet.UsedRange.Calculate 'if you are using usedrange recommend using this as sometimes usedrange behaves erratically
For Each col In sheet.UsedRange.Columns
'check if there are no entries and first row is also blank - make blank if both conditions are met
col.Hidden = IIf(col.Cells(1048576, 1).End(xlUp).Row = 1 And col.Cells(1, 1).Value = "", True, False)
DoEvents
Next col
End If
Next sheet
Application.ScreenUpdating = True
End Sub
Hide or Delete Blank Columns in Real Used Range
(Usually) Standard Module (Often 'Module1')
Option Explicit
'*******************************************************************************
' Purpose: Hides or deletes all blank columns in the Real Used Range
' of worksheets specified by a name pattern list.
' Remarks: The Real Used Range is calculated by using the Find method which
' avoids any possible 'errors' occuring when using the UsedRange
' property.
'*******************************************************************************
Sub HideDeleteColumnsOfRUR(Optional HideFalse_DeleteTrue As Boolean = False)
' Worksheet Name Pattern List
Const cSheets As String = "*Jan*,*Feb*,*Mar*,*Apr*,*May*,*Jun*,*Jul*," _
& "*Aug*,*Sep*,*Oct*,*Nov*,*Dec*"
' If a cell contains a formula that evaluates to "" and if cLookIn is
' equal to xlValues (-4163), it will not be found (Not blank).
Const cLookIn As Variant = -4123 ' -4163 Value, -4123 Formula, -4144 Comment
Dim ws As Worksheet ' (Current) Worksheet
Dim RUR As Range ' (Current) Real Used Range
Dim rngU As Range ' (Current) Union Range
Dim vntSheets As Variant ' Sheet Array
Dim i As Long ' Sheet Array Row Counter
Dim j As Long ' Used Range Column Counter
Application.ScreenUpdating = False
On Error GoTo ProcedureExit ' Enable ScreenUpdating if error occurs.
' Write Worksheet Name Pattern List to Sheet Array.
vntSheets = Split(cSheets, ",")
' Remove possible occurrences of leading and trailing spaces in
' Sheet Array.
'For i = 1 To UBound(vntSheets): vntSheets(i) = Trim(vntSheets(i)): Next
For Each ws In ThisWorkbook.Worksheets ' Loop through worksheets.
For i = 0 To UBound(vntSheets) ' Loop through Worksheet Name Patterns.
If ws.Name Like vntSheets(i) Then ' Worksheet Name Pattern found.
' Unhide all columns, calculate Real Used Range and Union Range.
GoSub RangeAccumulator
Exit For ' Stop checking for (Current) Worksheet Name Patterns.
End If
Next
Next
ProcedureExit:
Application.ScreenUpdating = True
Exit Sub
RangeAccumulator:
With ws
' Unhide all columns in (Current) Worksheet.
.Columns.Hidden = False
' Calculate Real Used Range.
If Not .Cells.Find("*", .Cells(.Rows.Count, .Columns _
.Count), -4123, , 1) Is Nothing Then ' Is not empty sheet.
Set RUR = .Range(.Cells(.Cells.Find("*", .Cells(.Rows.Count, _
.Columns.Count)).Row, .Cells.Find("*", .Cells(.Rows.Count, _
.Columns.Count), , , 2).Column), .Cells(.Cells _
.Find("*", , , , 1, 2).Row, .Cells.Find("*", , , , 2, 2) _
.Column))
Else ' Is empty sheet.
'MsgBox "Worksheet '" & ws.Name & "' is an empty sheet."
Return
End If
End With
' Accumulate Union Range using only Real Used Range's first-row cells (1).
With RUR
For j = 1 To .Columns.Count
If .Columns(j).Find("*", , cLookIn, , 2, 2) Is Nothing Then
If Not rngU Is Nothing Then
Set rngU = Union(rngU, .Cells(1, j))
Else
Set rngU = .Cells(1, j)
End If
End If
Next
End With
' Hide or Delete Union Range's columns.
If Not rngU Is Nothing Then
With rngU.EntireColumn
If Not HideFalse_DeleteTrue Then
.Hidden = True
Else
.Delete
End If
End With
Set rngU = Nothing
End If
Return
End Sub
'*******************************************************************************
'*******************************************************************************
' Purpose: Shows (unhides) all blank columns in worksheets specified by
' a name pattern list.
'*******************************************************************************
Sub ShowAllColumns()
' Worksheet Name Pattern List
Const cSheets As String = "*Jan*,*Feb*,*Mar*,*Apr*,*May*,*Jun*,*Jul*," _
& "*Aug*,*Sep*,*Oct*,*Nov*,*Dec*"
Dim ws As Worksheet ' (Current) Worksheet
Dim vntSheets As Variant ' Sheet Array
Dim i As Long ' Sheet Array Row Counter
Application.ScreenUpdating = False
On Error GoTo ProcedureExit ' Enable ScreenUpdating if error occurs.
' Write Worksheet Name Pattern List to Sheet Array.
vntSheets = Split(cSheets, ",")
' Remove possible occurrences of leading and trailing spaces in
' Sheet Array.
'For i = 1 To UBound(vntSheets): vntSheets(i) = Trim(vntSheets(i)): Next
For Each ws In ThisWorkbook.Worksheets ' Loop through worksheets.
For i = 0 To UBound(vntSheets) ' Loop through Worksheet Name Patterns.
If ws.Name Like vntSheets(i) Then ' Worksheet Name Pattern found.
' Unhide all columns in (Current) Worksheet.
ws.Columns.Hidden = False
Exit For ' Stop checking for (Current) Worksheet Name Patterns.
End If
Next
Next
ProcedureExit:
Application.ScreenUpdating = True
End Sub
'*******************************************************************************
(Usually) Sheet Module (Often 'Sheet1', 'Sheet2' or...)
Option Explicit
'*******************************************************************************
Sub CommandButton1_Click()
' HIDES columns in Real Used Range.
HideDeleteColumnsOfRUR
End Sub
'*******************************************************************************
Sub CommandButton2_Click()
' Shows (unhides) columns.
ShowAllColumns
End Sub
'*******************************************************************************
'Sub CommandButton3_Click()
' ' DELETES columns in Real Used Range.
' HideDeleteColumnsOfRUR True ' (or probably any number different than 0.)
'End Sub
'*******************************************************************************
I am searching a column for cell that contains text and does not contain the word "cat" in the first 6 characters (needs to be case insensitive). This will then cut that entire row to another sheet. Cannot get the code to run without compile errors. the below code is before i try to change it. I do not know how to code it to look at the first 6 characters.
tried instr & iserror but i think my existing code just needs a small alteration which escapes me.
Sub CATDEFECTS()
UsdRws = Range("C" & Rows.Count).End(xlUp).Row
For i = UsdRws To 2 Step -1
If Range("C" & i).Value Like "<>""" And Range("c" & i).Value Like "CAT" Then
Rows(i).Cut Sheets("AWP DEFECTS").Range("A" & rows.Count).End(xlUp).Offset(1)
Rows(i).Delete
End If
Next i
End Sub
Regardless of how you decide to implement the macro, your test to see if a cell is blank is entirely redundant. You can just test if the cell meets your CAT criteria. If it does, it is definitely not blank so no need to test it.
Method 1
You can look at the first 6 characters with LEFT(Range, 6)
If Left(Range("C" & i), 6) Like "*CAT*" Then
This needs Option Compare to work (Thanks #Comintern)
Method 2
I would prefer this method. Its explicit and does not delete or shift anything inside the loop so your action statements are greatly minimized.
Sub Cat()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<--UPDATE
Dim ps As Worksheet: Set ps = ThisWorkbook.Sheets("AWP DEFECTS")
Dim LR As Long, DeleteMe As Range, i As Long
LR = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
For i = 2 To LR
If InStr(Left(ws.Range("C" & i), 6), "CAT") Then
If Not DeleteMe Is Nothing Then
Set DeleteMe = Union(DeleteMe, ws.Range("C" & i))
Else
Set DeleteMe = ws.Range("C" & i)
End If
End If
Next i
Application.ScreenUpdating = False
If Not DeleteMe Is Nothing Then
LR = ps.Range("A" & ps.Rows.Count).End(xlUp).Row
DeleteMe.EntireRow.Copy ps.Range("A" & LR)
DeleteMe.EntireRow.Delete
End If
Application.ScreenUpdating = True
End Sub
If cat is within the first 6 characters then InStr will report its position being less than 5.
Sub CATDEFECTS()
dim UsdRws as long, pos as long
UsdRws = Range("C" & Rows.Count).End(xlUp).Row
For i = UsdRws To 2 Step -1
pos =instr(1, cells(i, "C").value2, "cat", vbtextcompare)
If pos > 0 and pos < 5 Then
Rows(i).Cut Sheets("AWP DEFECTS").Range("A" & rows.Count).End(xlUp).Offset(1)
Rows(i).Delete
End If
Next i
End Sub
Criteria Backup (Hide/Delete)
To enable the deletion of the rows in the Source Worksheet you have to set cDEL to True in the constants section. Adjust the other constants to fit you needs.
The Code
Option Explicit
'Option Compare Text
Sub CATDEFECTS()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo ProcedureExit
' Source Constants
Const cSource As Variant = "Sheet1" ' Worksheet Name/Index
Const cCol As Variant = "C" ' Search Column Letter/Number
Const cFirstR As Long = 2 ' First Row Number
Const cChars As Long = 6 ' Number of Chars
Const cSearch As String = "CAT" ' Search String
' Target Constants
Const cTarget As Variant = "AWP DEFECTS" ' Worksheet Name/Index
Const cColTgt As Variant = "A" ' Column Letter/Number
Const cFirstRTgt As Long = 2 ' First Row Number
Const cDEL As Boolean = False ' Enable Delete (True)
' Variables
Dim rngH As Range ' Help Range
Dim rngU As Range ' Union Range
Dim vntS As Variant ' Source Array
Dim i As Long ' Source Range Row Counter
' The Criteria
' When the first "cChars" characters do not contain the case-INsensitive
' string "cSearch", the criteria is met.
' Source Worksheet
With ThisWorkbook.Worksheets(cSource)
' Calculate Last Cell in Search Column using the Find method and
' assign it to Help (Cell) Range.
Set rngH = .Columns(cCol).Find("*", , xlFormulas, _
xlWhole, xlByColumns, xlPrevious)
' Calculate Source Column Range from Help (Cell) Range.
If Not rngH Is Nothing Then ' Last Cell was found.
' Calculate Source Column Range and assign it to
' Help (Column) Range using the Resize method.
Set rngH = .Cells(cFirstR, cCol).Resize(rngH.Row - cFirstR + 1)
' Copy Help (Column) Range into 2D 1-based 1-column Source Array.
vntS = rngH
' Show hidden rows to prevent the resulting rows (the rows to be
' hidden or deleted) to appear hidden in Target Worksheet.
rngH.EntireRow.Hidden = False
Else ' Last Cell was NOT found (unlikely).
MsgBox "Empty Column '" & cCol & "'."
GoTo ProcedureExit
End If
' Loop through rows of Source Array.
For i = 1 To UBound(vntS)
' Check if current Source Array value doesn't meet Criteria.
If InStr(1, Left(vntS(i, 1), cChars), cSearch, vbTextCompare) = 0 _
Then ' "vbUseCompareOption" if "Option Compare Text"
' Note: To use the Like operator instead of the InStr function
' you have to use (uncomment) "Option Compare Text" at the beginning
' of the module for a case-INsensitive search and then outcomment
' the previous and uncomment the following line.
' If Not Left(vntS(i, 1), cChars) Like "*" & cSearch & "*" Then
Set rngH = .Cells(i + cFirstR - 1, cCol)
If Not rngU Is Nothing Then
' Union Range contains at least one range.
Set rngU = Union(rngU, rngH)
Else
' Union Range does NOT contain a range (only first time).
Set rngU = rngH
End If
End If
Next
End With
' Target Worksheet
If Not rngU Is Nothing Then ' Union Range contains at least one range.
With ThisWorkbook.Worksheets(cTarget)
' Calculate Last Cell in Search Column using the Find method and
' assign it to Help Range.
Set rngH = .Columns(cColTgt).Find("*", , xlFormulas, _
xlWhole, xlByColumns, xlPrevious)
' Calculate Last Cell from Help Range, but in column 1 ("A").
If Not rngH Is Nothing Then ' Last Cell was found.
Set rngH = .Cells(rngH.Row + 1, 1)
Else ' Last Cell was NOT found.
Set rngH = .Cells(cFirstRTgt - 1, 1)
End If
' Copy the entire Union Range to Target Worksheet starting from
' Help Range Row + 1 i.e. the first empty row (in one go).
' Note that you cannot Cut/Paste on multiple selections.
rngU.EntireRow.Copy rngH
End With
' Hide or delete the transferred rows (in one go).
If cDEL Then ' Set the constant cDEL to True to enable Delete.
rngU.EntireRow.Delete
Else ' While testing the code it is better to use Hidden.
rngU.EntireRow.Hidden = True
End If
End If
ProcedureExit:
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Remarks
The use of the array did not speed up considerably.
The InStr function was a few milliseconds faster than the Like operator in my data set.
Calculating the Real Used Range and copying it into a Source Array
and then writing the data that meets the criteria from Source Array
to a Target Array and copying the Target Array to the Target
Worksheet, might be faster, and/but would additionally copy the data without formulas or formatting.
I have a one dimensional column of cells containing text.
I would like to:
strip ".jpg" extension
duplicate each line and insert a copy of the duplicated line beneath it
for each duplicated line (every second line), add a suffix "-Alpha"
apply ".tif" extension to all of the cells
Data looks like this:
0120-052.jpg
0120-053.jpg
0120-054.jpg
0120-055.jpg
0120-056.jpg
I would like to select that range and it appear like so:
0120-052.tif
0120-052-Alpha.tif
0120-053.tif
0120-053-Alpha.tif
0120-054.tif
0120-054-Alpha.tif
0120-055.tif
0120-055-Alpha.tif
0120-056.tif
0120-056-Alpha.tif
I found out how to insert entire rows between the existing data, but I have other data to the left of this data and don't want to have blank rows running across my entire spreadsheet. I did find a way to insert blanks between the existing data but I could not figure out how to instead paste the data when inserting. I fudged something together, but it tried to paste infinitely.
I think I need to put it all into an array and iterate on a step by step basis, but I was unable to figure out how to do that based off of an arbitrary selection.
Sub PasteInsertRowsAfter()
Dim MyCell As Range
For Each MyCell In Selection
If MyCell.Value <> "" Then
MyCell.Copy
MyCell.Offset(1, 0).Insert shift:=xlDown
MyCell.Offset(2, 0).Select
End If
Next MyCell
End Sub
Does this work for you?
Sub PasteInsertRowsAfter()
Dim i As Long
Dim MyCell As Range
Dim Rng As Range
Set Rng = Selection
For i = Rng.Cells.Count To 1 Step -1
Set MyCell = Rng.Cells(i)
MyCell.Copy
MyCell.Offset(1, 0).Insert shift:=xlDown
MyCell.Value = Replace(MyCell.Value, ".jpg", ".tif")
MyCell.Offset(1, 0).Value = Replace(MyCell.Offset(1, 0), ".jpg", "-Alpha.tif")
Next i
End Sub
This sounds like bad data structure to me (inserting rows) so this solution will be based on a column structured table. However, I don't know much else about the data so this could be a wrong assumption on my end.
You could store your values in columns instead like so | Original String | .jpg | -Alpha.tif |
Where Original String is the header for Column A and so on. Your data will be better organized this way since all modifications of original string will be stored on a single row. This structure will allow you to add other info that may be relevant at some point in time (source, date, etc.). You can create pivots with this format and monitor for duplicates easier. You can even store the original string.
Input/Output of macro are below.
This sub is a simple loop that does not take a Slection range.
Sub Alternative()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim MyRange As Range: Set MyRange = ws.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
Dim MyCell As Range
Application.ScreenUpdating = False
For Each MyCell In MyRange
MyCell.Offset(, 1) = Replace(MyCell, "jpg", "tif")
MyCell.Offset(, 2) = Replace(MyCell, ".jpg", "-Alpha.tif")
Next MyCell
Application.ScreenUpdating = True
End Sub
Here is an option that allows the user to select a range once the macro is launched. Just as the above solution, the macro will output the data in the 2 columns to left of selected range.
Sub Alternative()
Dim MyRange As Range, MyCell As Range
On Error Resume Next 'Allow for Cancel Button
Set MyRange = Application.InputBox("Select Range", Type:=8)
On Error GoTo 0
If Not MyRange Is Nothing Then
Application.ScreenUpdating = False
For Each MyCell In MyRange
MyCell.Offset(, 1) = Replace(MyCell, "jpg", "tif")
MyCell.Offset(, 2) = Replace(MyCell, ".jpg", "-Alpha.tif")
Next MyCell
Application.ScreenUpdating = True
End If
End Sub
Trim160ConcatArrayPaste
Option Explicit
'With Sub ======================================================================
' .Title: Trim160ConcatArrayPaste
' .Author: YMG
'-------------------------------------------------------------------------------
Sub Trim160ConcatArrayPaste()
'Description
' Manipulates data in a selected worksheet range and pastes the result into
' another range (overwriting the former range and more).
'Parameters
' None
'Returns
' Manipulated data in a range.
'
'-- Customize BEGIN --------------------
Const cStr1 As String = ".jpg"
Const cStr2 As String = ".tif"
Const cStr3 As String = "-Alpha.tif"
'If the result should be pasted into another row. Probably useless.
Const loROff As Long = 0 'Row Offset for Array Data
''''''''''''''''''''''''''''''''''''''''
'If the result should be pasted into another column
Const iCOff As Integer = 0 'Column Offset for Array Data
'Remarks:
' I strongly urge you to consider pasting the data into another column e.g.
' the column adjacent to the right of the starting column (Set iCoff = 1).
' If something goes wrong while pasting you will overwrite your initial data
' and you might lose a lot of time getting it back.
' Creating a log file might be considered.
''''''''''''''''''''''''''''''''''''''''
'
'-- Customize END ----------------------
'
Dim oXL As Application 'Exel Application Object
Dim oWb As Workbook 'Workbook Object - ActiveWorkbook
Dim oWs As Worksheet 'Worksheet Object - ActiveSheet
Dim oRng As Range 'Range Object - Range to read from, Range to write to
Dim oCell As Range 'Cell - Range Object - All cells of oRng
Dim arrTCC() As String
Dim lo1 As Long 'Data Entries Counter, Array Entries Counter
Dim strCell As String
Dim strArrRng As String
'
'-------------------------------------------------------------------------------
'Assumptions
' There is a contiguous range (oRng) in the ActiveSheet (oWs) of the
' ActiveWorkbook (oWb) that contains a list of entries in its cells
' (oRng.Cells) to be processed. ('Data' for 'list of entries' in further text)
' The actual range of the Data is selected.
'-------------------------------------------------------------------------------
'
Set oXL = Application
Set oWb = ActiveWorkbook
Set oWs = oWb.ActiveSheet
Set oRng = oXL.Selection
'
'Remarks:
' The Selection Property is a property of the Application object and the
' Window object. Visual Basic doesn't allow ActiveWorkbook.Selection or
' ActiveSheet.Selection.
'
''''''''''''''''''''''''''''''''''''''''
'Task:
' Count the number of Data entries.
'
lo1 = 0 'Data Entries Counter
For Each oCell In oRng.Cells
lo1 = lo1 + 1
Next
'
'Status:
' 'lo1' is the number of Data entries which will be used to determine the
' size of an array in the following code.
'
''''''''''''''''''''''''''''''''''''''''
'Task: Populate an array with the desired results.
'
ReDim arrTCC(1 To lo1 * 2, 1 To 1)
'Explaination:
'"lo1" - Number of list entries.
'" * 2" - Making 2 entries out of each entry.
lo1 = 0 'Array Entries Counter (This is a 1-based array.)
For Each oCell In oRng.Cells
'Clean the text of the Data entries.
strCell = Trim(oCell.Text)
'Remarks:
'Chr(160) which is a non-breaking space (HTML Name: ) is at
'the end of the Data entries. The Trim function doen't clean
'non-breaking spaces.
strCell = Replace(strCell, Chr(160), "")
'Check the last part of the string
If Right(strCell, Len(cStr1)) = cStr1 Then
'Populate array.
lo1 = lo1 + 1
arrTCC(lo1, 1) = Replace(strCell, cStr1, cStr2)
lo1 = lo1 + 1
arrTCC(lo1, 1) = Replace(strCell, cStr1, cStr3)
'If the cell doesn't end with cStr1:
Else 'This should never happen, remember: COUNTIGUOUS.
'An Idea
' lo1 = lo1 + 1
' arrTCC(lo1, 1) = ""
' lo1 = lo1 + 1
' arrTCC(lo1, 1) = ""
MsgBox "You might have selected a wrong range.", vbCritical
Exit Sub
End If
Next
'
' For lo1 = LBound(arrTCC) To UBound(arrTCC)
' Debug.Print arrTCC(lo1, 1)
' Next
' Debug.Print LBound(arrTCC)
' Debug.Print UBound(arrTCC)
'
'Status: The array 'arrTCC' is populated
'
''''''''''''''''''''''''''''''''''''''''
'Task:
' Determine the range where to paste the data from array and paste the
' array into the range.
'
'Calculate the 'Start' Cell Address
strArrRng = oRng.Cells(1 + loROff, 1 + iCOff).Address
'
' Debug.Print strArrRng
'
'Add the ":" (Address Separator) and the Calculated 'End' Cell Address
strArrRng = strArrRng & ":" & _
oRng.Cells(UBound(arrTCC) + loROff, 1 + iCOff).Address
'Paste the Array to the Worksheet
Set oRng = oWs.Range(strArrRng)
'
' Debug.Print strArrRng
' Debug.Print oRng.Address
'
oRng = arrTCC
'
'Status: Done
'
'Remarks:
'Testing the program was done with iCoff = 1 i.e. pasting the array data
'into the column adjacent to the right of the starting column. Since it uses
'overwriting the Data, the Data would always need to be written back for
'further testing.
'Some debugging code has deliberately been commented and left inside the
'program to remind amateurs like myself of debugging importance.
'Some other aspects of this program could be considered like the column
'of the data could be known or unknown so a range, a column or the
'ActiveCell would have or don't have to be selected etc.
'
End Sub
'-------------------------------------------------------------------------------
'With Source Idea --------------------------------------------------------------
' .Title: Excel VBA seemingly simple problem: Trim, Copy (insert), Concat on selected range
' .TitleLink: https://stackoverflow.com/questions/52548294/excel-vba-seemingly-simple-problem-trim-copy-insert-concat-on-selected-rang
' .Author: NewbieStackOr
' .AuthorLink: https://stackoverflow.com/users/10427336/newbiestackor
'End With ----------------------------------------------------------------------
'End With ======================================================================