I have a code that finds and replaces values in one sheet from a list in another sheet. However, I need this code to also highlight the cell, or flag it in some way so that it can be reviewed manually later. Any suggestions?
Here is the code:
Sub ReplaceValues()
Dim FandR As Worksheet
Dim PDH As Worksheet
Dim rng As Range, rngR As Range
Dim i As Long
Dim rngReplacement
Dim c As Range
Dim curVal As String
Set FandR = Sheets("Find and Replace")
Set PDH = ThisWorkbook.Sheets("Paste Data here")
i = PDH.Rows.Count
With PDH
Set rng = .Range("E1", .Range("E" & i).End(xlUp))
End With
With FandR
Set rngR = FandR.Range("H")
End With
For Each c In rngR
curVal = c.Value
c.Interior.Color = vbYellow
With rng
.Replace curVal, c.Offset(0, 1).Value, xlWhole, , True
End With
Next
End Sub
Related
is this possible to create a function that returns temporary sheet?
Let's say I have got Sub as follow
Sub My_Sub()
Dim harm As Worksheet
Set harm = Sheets("my_sheet")
Dim lastRow As Long, arr
lastRow = harm.Range("A" & harm.Rows.Count).End(xlUp).Row
arr = harm.Range("T2:V" & lastRow).Value
MsgBox arr(2,5)+1
End Sub
Right now I'm working on harm = Sheets("my_sheet") and it loads whole sheet. Now I want to select part of that sheet and do the same operations so I wanted to write a function that will create temporary sheet, return it so in My_Sub I would have Set harm = ReturnSheet().
Is it possible? I want to load pseudo sheet from function, so I don't need to change anything in My_Sub (I mean those Ranges with column letter indexes).
Function ReturnSheet() As Worksheet
Dim Rng As Range
Dim lastRow As Long
Dim lastCol As Long
Set Rng = Selection
lastRow = Selection.Rows.Count
lastCol = Selection.Columns.Count
ReturnSheet.Range("A2").Resize(lastRow, lastCol).Value = Rng
End Function
Right now I'm getting Object variable or with block variable not set at ReturnSheet.Range("A2").Resize(lastRow, lastCol).Value = Rng
Try using the next Function. It returns a range meaning the selected cells without their first row:
Function ReturnRange(Optional boolAllRange As Boolean = False) As Range
Dim rng As Range: Set rng = Selection
If rng.rows.count = 1 Then Exit Function
If boolAllRange Then
Set ReturnRange = rng
Else
Set ReturnRange = rng.Offset(1).Resize(rng.rows.count - 1, rng.Columns.count)
End If
End Function
You can test it using the next Sub:
Sub testReturnRange()
Dim rng As Range
Set rng = ReturnRange 'eliminating the header
If Not rng Is Nothing Then Debug.Print rng.Address
Set rng = ReturnRange(True) 'header inclusive...
If Not rng Is Nothing Then Debug.Print rng.Address
End Sub
I am needing to add a .mp3 to the end of each entry in two columns. I have the code below which works but I have to select each item in the column and it applies it to those cells.
But I would like to have a code that would automatically add the .mp3 to the end of any entry in column B and D.
Here is my current code:
Sub AppendToExistingOnRight()
Dim c as range
For each c in Selection
If c.value <> "" Then c.value = c.value & ".mp3”
Next
End Sub
Any assistance would be appreciate to help make this just a little more efficient.
A solution without looping. I am showing it for columnB. Feel free to adapt it for column D
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rng As Range
Dim sAddr As String
Dim lRow As Long
'~~> Change sheet name as applicable
Set ws = Sheet1
With ws
'~~> Find last row in Col B
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
'~~> Construct your range
Set rng = Range("B1:B" & lRow)
sAddr = rng.Address
'~~> Append ".mp3" to the entire range in 1 go
rng = Evaluate("index(concatenate(" & sAddr & ","".mp3""),)")
End With
End Sub
In Action
If you would like to understand how this works then you may want to see Convert an entire range to uppercase without looping through all the cells
I've added references to the workbook, worksheet, and set ranges which are then looped. I've also added a check to verify if ".mp3" already exists at the end of the cell. Finally, I prevented the screen from updating until the script has completed.
If you want it to run faster, specify the range (ie. ws.Range("B1:B1000") will check 1000 cells rather than 1048576).
Sub AppendToExistingOnRight()
Application.ScreenUpdating = False
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.ActiveSheet
Dim c As Range
Dim colB As Range: Set colB = ws.Range("B:B")
Dim colD As Range: Set colD = ws.Range("D:D")
For Each c In colB
If c.Value <> "" And Right(c.Value, 4) <> ".mp3" Then c.Value = c.Value & ".mp3"
Next
For Each c In colD
If c.Value <> "" Then c.Value = c.Value & ".mp3"
Next
Application.ScreenUpdating = True
End Sub
Try below sub. If your data is same in Column B and Column D then you can use one loop.
Sub AddMP3()
Dim bRng As Range, dRng As Range, mRng As Range
Set bRng = Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)
Set dRng = Range("D2:D" & Cells(Rows.Count, "D").End(xlUp).Row)
For Each mRng In bRng
mRng = mRng & ".mp3"
Next
For Each mRng In dRng
mRng = mRng & ".mp3"
Next
Set bRng = Nothing
Set dRng = Nothing
End Sub
Looking for a simple loop through the range (say column A range("A5:A15")) if there is a blank cell within that range I need the entire row/rows associated with the blank cell/cells to be hidden.
I was thinking of something like this to accommodate various ranges but get "type Mismatch" error. Any reasons why
Sub test()
Dim rng As Range, cell As Variant, ar As Variant
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range
Dim MyArray(1 To 4) As Range
With ThisWorkbook.Worksheets("sheet1")
'Set MyArray = rng
Set MyArray(1) = Range("O8:O17")
Set MyArray(2) = Range("O55:O64")
Set MyArray(3) = Range("G37:G46")
Set MyArray(4) = Range("G89:G98")
'ar = Array(Rng1, Rng2, Rng3, Rng4)
'Set rng = .Range("O8:O17")
For Each cell In MyArray
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next cell
End With
End Sub
?
Something Like this:
You can put it in a subject:
For Each cell In Range("A5:A15")
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next
For Each cell In Range("A40:A55")
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next
New Answer :
Dim rng As Range, cell As Variant, ar As Variant
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range
Dim MyArray(1 To 4) As Range
With ThisWorkbook.Worksheets("sheet1")
'Set MyArray = rng
Set MyArray(1) = Range("O8:O17")
Set MyArray(2) = Range("O55:O64")
Set MyArray(3) = Range("G37:G46")
Set MyArray(4) = Range("G89:G98")
'ar = Array(Rng1, Rng2, Rng3, Rng4)
'Set rng = .Range("O8:O17")
Dim i As Integer
For i = LBound(MyArray) To UBound(MyArray)
For Each cell In MyArray(i)
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next
Next
End With
Try:
Option Explicit
Sub test()
Dim rng As Range, cell As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .Range("A5:A15")
For Each cell In rng
If cell.Value = "" Then
.Rows(cell.Row).EntireRow.Hidden = True
End If
Next cell
End With
End Sub
This takes full advantage of the Excel VBA model. I'm guessing it's faster than the above but have not conducted performance tests.
Dim Cell As Range
For Each Cell In Range("A5:A15").SpecialCells(xlCellTypeBlanks)
Cell.EntireRow.Hidden = True
Next
Try the following
Option Explicit
Sub youcouldhaveatleasttriedtodosomethingyourself()
Dim r1 As Range, r2 As Range, c As Range, target As Range
With Workbooks(REF).Sheets(REF)
Set r1 = .Range("A1:A54")
Set r2 = .Range("F3:F32")
Set target = Application.Union(r1, r2)
For Each area In target.Areas
For Each c In area
If c.Value = vbNullString Then .Rows(c.Row).EntireRow.Hidden = True
Next c
Next area
End With
End Sub
Please note that I now have set two exemplifying ranges. You can always add more range variables to the Union function.
Sub FillEmptyCell()
Dim rng As Range
Dim i As Long
Dim cell As Range
Dim sht As Worksheet
Set sht = ActiveWorkbook.Sheets("Sheet1")
sht.Activate
Set rng = Range(Range("C12"), Range("AD" & sht.UsedRange.Rows.Count))
For Each cell In rng
If cell.Value = "" Then
cell.Value = "0"
End If
Next
End Sub
I am trying to fill my blank spaces in sheet with zero dynamically.However,
I don't want this to fill zeroes in row that have no data. can someone help please?
See how this works,
Sub ZeroStuff()
Dim LstRw As Long, rng As Range, sh As Worksheet, c As Range
Set sh = Sheets("Sheet1")
With sh
LstRw = .Cells(.Rows.Count, "C").End(xlUp).Row + 1
Set rng = .Range("C12:C" & LstRw).SpecialCells(xlCellTypeBlanks)
For Each c In rng.Cells
.Range(c.Offset(, 1), c.Offset(, 27)) = 0
Next c
End With
End Sub
I have a bunch of column of rows that contain text such as:
dog,cat,mouse
bat,dog,fly
fish,beaver,horse
I'm trying to search and highlight rows that contain certain word:
Public Sub MarkDuplicates()
Dim iWarnColor As Integer
Dim rng As Range
Dim rngCell As Variant
Dim LR As Long
Dim vVal
Dim tRow
LR = Cells(Rows.Count, "B").End(xlUp).Row
Set rng = Range("B1:B" & LR)
iWarnColor = xlThemeColorAccent2
For Each rngCell In rng.Cells
tRow = rngCell.Row
If InStr(rngCell.Value, "dog") = 1 Then
rngCell.Interior.ColorIndex = iWarnColor
Else
rngCell.Interior.Pattern = xlNone
End If
Next
End Sub
This works fine so long as the word 'dog' is the first word in the comma string, so it would highlight the first row but not row two because the word 'dog' appears after 'bat'. Do I need to strip the commas out first or is there a better way of doing this?
It looks like your ultimate goal is to color the row based on whether or not 'dog' is in a cell. Here's a different way to do it that doesn't even involve VBA (this example assumes your data is all in column A):
Make a new column to the right. Use the formula =IF(NOT(ISERROR(FIND("dog",A1))),1,0). You can hide the column later so the user doesn't see it. Basically, if it has the word 'dog' somewhere, then return 1 else 0.
Select the entire first row
Under Conditional Formatting, go to New Rule
Choose Use a Formula
For your formula, try =$B2=1
Now that you've conditionally colored one row, copy and paste format to the other rows.
All rows should now update automatically.
Extra Credit: If this data is formatted as a table object, the conditional formatting should automatically carry over to new rows as they are added.
Further to my comments above
Example 1 (Using .Find and .Findnext)
Option Explicit
Public Sub MarkDuplicates()
Dim ws As Worksheet
Dim iWarnColor As Integer
Dim rng As Range, aCell As Range, bCell As Range
Dim LR As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
iWarnColor = xlThemeColorAccent2
With ws
LR = .Range("B" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B1:B" & LR)
rng.Interior.ColorIndex = xlNone
Set aCell = rng.Find(What:="dog", LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
aCell.Interior.ColorIndex = iWarnColor
Do
Set aCell = rng.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
aCell.Interior.ColorIndex = iWarnColor
Else
Exit Do
End If
Loop
End If
End With
End Sub
Screenshot
Example 2 (Using Autofilter)
For this ensure that there is a Heading in Cell B1
Option Explicit
Public Sub MarkDuplicates()
Dim ws As Worksheet
Dim iWarnColor As Integer
Dim rng As Range, aCell As Range
Dim LR As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
iWarnColor = xlThemeColorAccent2
With ws
'~~> Remove any filters
.AutoFilterMode = False
LR = .Range("B" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B1:B" & LR)
With rng
.AutoFilter Field:=1, Criteria1:="=*dog*"
Set aCell = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
End With
If Not aCell Is Nothing Then aCell.Interior.ColorIndex = iWarnColor
'~~> Remove any filters
.AutoFilterMode = False
End With
End Sub