VBA find and replace skipping some cells - excel

I have a bit of code that finds blanks in a given column and replaces them with "BLANK", this has worked fine in the past and works for all of the sheets I am looking at bar one.
In the 'meter' sheet the whole column is blank, yet the find and replace fills all bar 6 of the blanks with no apparent pattern as below. I expect this could be another of my Monday morning 'user malfunction' errors but would appreciate any insight.
I am aware this would be better in a loop, which I will write once I've fixed the problem of it missing some blanks.
Cheers
Public Function FILL_blanks() '''' this searches for blanks
'in the columns in the raw data we are interested in and replaces
'them with BLANK there is a value assigned to BLANK in the flag matrix.
Dim LastRow_g As Long '''' HYDRANT, NODE ---->CHANGES LENGTH FOR EACH ASSET
Dim LastRow_j As Long ''''
Dim LastRow_bp As Long ''''
Dim WS_Count As Integer
Dim i As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For i = 1 To WS_Count
If ActiveWorkbook.Worksheets(i).Name = "hydrant" Then
Worksheets(i).Select
Range("g4").Select ' this will change j/g/bp only
LastRow_g = Range("g" & Rows.Count).End(xlUp).Row 'define the last row as all of the rows in DMA flag column
Range("r4:r" & LastRow_g).Select
'find and replace below
Selection.Replace What:="", Replacement:="BLANK", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ElseIf ActiveWorkbook.Worksheets(i).Name = "meter" Then
Worksheets(i).Select
Range("j4").Select
LastRow_j = Range("j" & Rows.Count).End(xlUp).Row 'define the last row
Range("y4:y" & LastRow_j).Select
'find and replace below
Selection.Replace What:="", Replacement:="BLANK", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

I would use Sub here rather than Function because there doesn't seem to be a return. This code replaces blank cells in the columns specified above:
Option Explicit
Sub FillBlanks2() '''' this searches for blanks
Dim LastRow As Long '''' HYDRANT, NODE ---->CHANGES LENGTH FOR EACH ASSET
Dim Sheet As Worksheet
Dim TargetRange As Range
'loop through worksheets in this workbook
For Each Sheet In ThisWorkbook.Worksheets
If Sheet.Name = "hydrant" Then '<~ concerned with col G on hydrant sheet
With Sheet
LastRow = .Range("G" & .Rows.Count).End(xlUp).Row
Set TargetRange = .Range(.Cells(4, 7), .Cells(LastRow, 7))
End With
'apply replacement to the target range
TargetRange.Replace What:="", Replacement:="BLANK", LookAt:=xlWhole, SearchOrder:=xlByRows
ElseIf Sheet.Name = "meter" Then '<~ concerned with col J on hydrant sheet
With Sheet
LastRow = .Range("J" & .Rows.Count).End(xlUp).Row
Set TargetRange = .Range(.Cells(4, 10), .Cells(LastRow, 10))
End With
'apply replacement to the target range
TargetRange.Replace What:="", Replacement:="BLANK", LookAt:=xlWhole, SearchOrder:=xlByRows
End If
Next Sheet
End Sub

I adapted the code from Dan Wagner to account for cells that appear blank but actually have spaces in them. if the cells are only likely to contain a blank or one space then it is possible to use "" and " ".
However, I am sure there is a more elegant solution that accounts for all blank spaces. SpecialCells(xlCellTypeBlanks) is a possibility but it appears to be limited to a certain number of rows.
Sub FILL_blanks() '''' this searches for blanks
Dim LastRow As Long '''' HYDRANT, NODE ---->CHANGES LENGTH FOR EACH ASSET
Dim Sheet As Worksheet
Dim TargetRange As Range
Sheets("Sheet1").Select
LastRow = Range("a" & Rows.Count).End(xlUp).Row
Set TargetRange = Range("b4:b" & LastRow)
'apply replacement to the target range
'"" accounts for true blank cells (no spaces)
' "*" is a wildcard and accounts for one or more spaces
TargetRange.Replace What:="", replacement:="BLANK", LookAt:=xlWhole, SearchOrder:=xlByRows
TargetRange.Replace What:=" ", replacement:="BLANK", LookAt:=xlWhole, SearchOrder:=xlByRows
End Sub
Thanks again for your assistance

Related

Selecting a range until the last used row

I am trying to select a range until the last used row in the sheet. I currently have the following:
Sub Select_Active_Down()
Dim lr As Long
lr = ActiveSheet.UsedRange.Rows.Count
If Cells(ActiveCell.Row, ActiveCell.Column) = Cells(lr, ActiveCell.Column) Then
MsgBox "There isn't any data to select."
Else
Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(lr, ActiveCell.Column)).Select
Cells(lr, ActiveCell.Column).Activate
End If
End Sub
The issue is that I need to select multiple columns, and this will only select the first column of the active range. How can I modify this to select multiple columns rather than just the first?
What about selection the entire region? This can be done as follows in VBA:
Selection.CurrentRegion.Select
There also is the possibility to select the entire array. For that, just press Ctrl+G, choose Special and see over there.
I would do this slightly different. I would use .Find to find the last row and the last column (using the same logic shown in the link) to construct my range rather than using Selection | Select | ActiveCell | UsedRange | ActiveSheet.
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim rng As Range
'~~> Change it to the relevant sheet
Set ws = Sheet1
With ws
'~~> Check if there is data
If Application.WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "No Data Found"
Exit Sub
End If
'~~> Find last row
LastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'~~> Find last column
LastColumn = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
'~~> Construct your range
Set rng = .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))
'~~> Work with the range
With rng
MsgBox .Address
'
'~~> Do what you want with the range here
'
End With
End With
End Sub

Copy data between work books with dynamic cells

Trying to copy data from one Excel spreadsheet to another (from New_data to report).
In the New_data spreadsheet I find the second time System (hence why I start the search below the first one at N21) appears then I need to copy all data below it from columns b - k until I hit blank cells. How do I get the amount of rows to only capture filled cells?
Range("B584:K641") needs to be dynamic.
Sub CopyWorkbook()
Range("N21").Select
Cells.Find(What:="system", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Range("B584:K641").Select
Selection.Copy
Application.WindowState = xlNormal
Windows("report.xlsx").Activate
Range("A2").Select
ActiveSheet.Paste
Windows("new_data.csv"). _
Activate
End Sub
Try the next code please. It should be very fast (if I correctly understood where to be searched for 'system', starting with what...). The code assumes that "new_data.csv" is the csv workbook name. If not, you must use its real name when defining shCSV sheet:
Sub CopyWorkbook()
Dim shR As Worksheet, shCSV As Worksheet, lastRow As Long, systCell As Range, arr
Set shR = Workbooks("report.xlsx").ActiveSheet 'use here the sheet you need to paste
'it should be better to use the sheet name.
'No need to have the respective sheet activated at the beginning
Set shCSV = Workbooks("new_data.csv").Sheets(1) 'csv file has a single sheet, anyhow
lastRow = shCSV.Range("B" & rows.count).End(xlUp).row
Set systCell = shCSV.Range("B21:B" & lastRow).Find(What:="system", _
After:=shCSV.Range("B21"), LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If systCell Is Nothing Then MsgBox "No 'sytem' cell has been found...": Exit Sub
arr = shCSV.Range(systCell, shCSV.Range("K" & lastRow)).Value
shR.Range("A2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub
Try:
Sub test()
Dim LR As Long
Dim Ini As Long
LR = Range("B" & Rows.Count).End(xlUp).Row 'last non empty row in column B
Ini = Application.WorksheetFunction.Match("system", Range("N21:N" & LR), 0) + 20 'position of system after n21
Range("B" & Ini & ":K" & LR).Copy
'''rest of your code to paste
End Sub
Note that this code is searching word system only in column N. If it's somewhere else, you'll need to adapt the MATCH function
I set a range to equal the filtered range and start a loop to count how many none empty cells occur until the first empty cell in column B.
Sub CopyWorkbook()
ThisWorkbook.Sheets("new_data").Activate
Range("N21").Select
Dim rng As Range
Set rng = Cells.Find(What:="system", After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
Dim i As Double
i = rng.Row
Do Until ThisWorkbook.Sheets("new_data").Range("B" & i) = vbNullString
i = i + 1
Loop
i = i - 1
Range("B" & rng.Row & ":K" & i).Select
Selection.Copy
Application.WindowState = xlNormal
Windows("report.xlsx").Activate
Range("A2").Select
ActiveSheet.Paste
Windows("new_data.csv").Activate
End Sub
I found a Stack Overflow question that was helpful in finding an answer. Find cell address

Endless processing and stuck with replace and left

This is about VBA in excel.
I am trying to remove the sign "/" and cut the string length for every cell down to 31 to make those values valid as a name for a new sheet. The constraint is within the first two columns until the last occupied row.
My code compiled, however, it brought me endless processing and I have to task manager-exit every time after running it. Please take a look at it, thank you so much!
Sub replaceSpeCharaAndCutLength()
'selectPositionAndReplaceSpeCharaAndCutLength Macro
Dim cell As Range
Dim row As Long
For row = 7 To Sheet1.Cells(Rows.Count, 1).End(xlUp).row
Worksheets("Sheet1").Columns("A").Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
Worksheets("Sheet1").Columns("B").Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
For Each cell In Sheet1.Range("A:B").Cells
cell.Value = Left(cell.Value, 31)
Next cell
Next row
End Sub
Updated code 0142 08212020
Sub replaceSpeCharaAndCutLength()
'
' selectPositionAndReplaceSpeCharaAndCutLength Macro
'
Dim cell As Range
Worksheets("Sheet1").Columns("A").Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
Worksheets("Sheet1").Columns("B").Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
For Each cell In Sheet1.Range("A:B").Cells
cell.Value = Left(cell.Value, 31)
Next cell
End Sub
Range.Replace doesn't require a loop. You can also use Evaluate instead of the other loop:
Sub replaceSpeCharaAndCutLength()
Dim lastRow As Long
lastRow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
Dim rng As Range
Set rng = Sheet1.Range("A7:B" & lastRow)
rng.Replace _
What:="/", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True
rng.Value = rng.Parent.Evaluate("INDEX(LEFT(" & rng.Address & ",31),)")
End Sub

Excel macro to search for a keyword and and copy the entire row to another sheet

I have a excel sheet with around 50k rows and i need a macro to search for a cell in that sheet and if it finds it to copy the entire row to another sheet, my problem is that the keyword may be on multiple rows so if there are like 4 cells with that keyword i need it to copy all 4 rows and paste them in another sheet
Dim intPasteRow As Integer
intPasteRow = 2
Sheets("Sheet2").Select
Columns("A:AV").Select
On Error Resume Next
Selection.Find(What:="m12", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=True, SearchFormat:=True).Activate
If Err.Number = 91 Then
MsgBox "ERROR: 'Keyword' could not be found."
Sheets("Sheet1").Select
End
End If
Dim intRow As Integer
intRow = ActiveCell.Row
Rows(intRow & ":" & intRow).Select
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Paste
End Sub
Sub saci()
Dim rng As Range
Set rng = Range(ActiveCell, ActiveCell.Offset(10000, 0))
rng.EntireRow.Select
With Selection.EntireRow
.Cut
.Offset(.Rows.Count + 1).Insert
.Select
End With
Range("A4").Select
End Sub
so far its finding the first "m12" cell in Sheet2 and copies the entire row to Sheet1, how do i make it continue to search after finding "m12" and copy all rows with the "m12" in them instead of just the first one?

Is it possible to use VBA to make a conditional copy of the formula from the active cell down the column

I want to implement a VBA Code to work with multiple different sheets, for example: it starts by looking for a certain number in the first row, once it's found, it jumps to that column and types a certain formula into the 2nd cell in that column, so far it works good, But the issue is that I wanna make it to Autofill that formula down the column if the first cell in that row contains data.
Like if A2 is not blank, continue the auto fill the cell in the active column (let's say the active column is D, then the it would fill the Cell d2 if a2 not blank) and stops once the cell in A Column is blank .. etc
So, Is it possible?
Sub Macro1()
Rows("1:1").Select
Selection.Find(What:="156", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False).Activate
ActiveCell.Offset(1).Select
ActiveCell.FormulaR1C1 = _
"= "Formula will be here""
End Sub
Might be best to save a copy of your workbook before running the code below.
Maybe something like this is what you're after. If Find found something in column D, then it puts the dummy formula in the range D2:D?, where ? is whatever the last row in column A is (which I think is what you described).
Option Explicit
Sub Macro1()
Dim ws As Worksheet
Set ws = ActiveSheet ' Can you refer to the workbook and worksheet by name? Please do if possible
With ws
Dim cellFound As Range
Set cellFound = .Rows(1).Find(What:="156", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False)
If cellFound Is Nothing Then
MsgBox ("The value was not found in the first row of sheet '" & ws.Name & "'. Code will stop running now")
Exit Sub
End If
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range(cellFound.Offset(1), .Cells(lastRow, cellFound.Column)).FormulaR1C1 = "=""Formula will be here"""
End With
End Sub
Check this simple code, I think it will satisfy your needs:
Sub Macro1()
Rows("1:1").Select
Selection.Find(What:="156", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False).Activate
col_Num = ActiveCell.Column
total_Rows = WorksheetFunction.CountA(Range("A:A"))
Cells(2, col_Num).Select
Cells(2, col_Num) = "=Put your Formula here"
begin_Cell = Cells(2, col_Num).Address(False, False)
end_Cell = Cells(total_Rows, col_Num).Address(False, False)
Selection.AutoFill Destination:=Range(begin_Cell & ":" & end_Cell)
End Sub
There are easier ways to locate a column header label although I'm unclear on why you are using the LookAt:=xlPart argument. It seems to me you should not have to 'wildcard' the search but a 'wild card' search can be accommodated.
Sub FindnFill()
dim m as variant
with worksheets("sheet1")
m = application.match("*156*", .rows(1), 0)
if not iserror(m) then
if not isempty(.cells(2, "A")) then
.range(.cells(2, m), .cells(.rows.count, "A").end(xlup).offset(0, m-1)).formula = _
"=""formula goes here"""
else
.cells(2, m).formula = _
"=""formula goes here"""
end if
end if
end with
end sub
Find & Fill
About the Find Method
It is best practice to always set the following three parameters, because they
are saved each time they are used.
LookIn - If you use xlFormulas, it will find e.g. =A2 + 156, which you don't want.
LookAt - If you use xlPart it will find e.g. 1567, which you don't want.
SearchOrder - Not important, since a row is being searched.
Additionally SearchDirection is by default xlNext and can therefore safely be omitted.
Additionally MatchCase is by default False and can therefore safely be omitted.
Additionally SearchFormat - To use it you previously have to set Application.FindFormat.NumberFormat and can therefore safely be omitted.
The Code
Sub FindFill()
Const cDblFind As Double = 156 ' Found Value
Const cLngRow As Long = 1 ' Found Row Number
Const cVntColumn As Variant = "A" ' First Column Letter/Number
Const cStrFormula As String = "=RC[-1]+5" ' Formula
Dim objFound As Range ' Found Column Cell Range
Dim lngRow As Long ' First Column Non-empty Rows
With ActiveSheet.Rows(cLngRow)
' Check if cell below cell in First Column and Found Row is empty.
If .Parent.Cells(cLngRow, cVntColumn).Offset(1, 0).Value = "" Then Exit Sub
' Calculate First Column Non-empty Rows.
lngRow = .Parent.Cells(cLngRow, cVntColumn).End(xlDown).Row - cLngRow
' Find cell in Found Row containing Found Value.
Set objFound = .Find(What:=cDblFind, After:=.Cells(.Row, .Columns.Count), _
LookIn:=xlValues, LookAt:=xlWhole, Searchorder:=xlByRows)
If Not objFound Is Nothing Then
' Write Formula to Found Column Range
objFound.Offset(1, 0).Resize(lngRow).FormulaR1C1 = cStrFormula
End If
End With
End Sub

Resources