VBA Excel find and replace WITHOUT replacing items already replaced - vba

I am looking to make an excel script that can find and replace data, but for the love of everything I cannot figure out how to write it.
Situation:
A-----------B-----------C
Cat-------Dog------Banana
Dog------Fish------Apple
Fish------Cat-------Orange
So the macro would look at the data in a cell in column B, then look at the adjacent cell in column C, and replace all instances of that data in column A with what if found in C. So the results would be:
A---------------B-----------C
Orange------Dog------Banana
Banana------Fish------Apple
Apple--------Cat-------Orange
But that's not all, I would like it to not change cells in A that already have been changed once! (I'm trying this with changing the background colour)
Any help? I am at a complete loss.
EDIT:
Okay I found out how to do the easy part (replacing), but I cannot find out how to not change cells that already have been changed once. Here is my code:
Sub multiFindNReplace()
Dim myList, myRange
Set myList = Sheets("sheet1").Range("A2:B3") 'two column range where find/replace pairs are
Set myRange = Sheets("sheet1").Range("D2:D5") 'range to be searched
For Each cel In myList.Columns(1).Cells
myRange.Replace what:=cel.Value, replacement:=cel.Offset(0, 1).Value, ReplaceFormat:=True
Next cel
End Sub
As far as I can tell, ReplaceFormat:=True
doesn't do anything ;/ so items that already have been replaced once still are being replaced! Is there a way to somehow make this work?

Here's the answer using your recommendation with color as a one-time limiter:
Sub Replace_Once()
'Find last row using last cell in Column B
LastRow = Range("B" & Rows.Count).End(xlUp).Row
'Clear colors in Column A
Range("A1:A" & LastRow).Interior.ColorIndex = xlNone
'Look at each cell in Column B one at a time (Cel is a variable)
For Each Cel In Range("B1:B" & LastRow)
'Compare the cell in Column B with the Value in Column A one at a time (C is a variable)
For Each C In Range("A1:A" & LastRow)
'Check if the Cell in Column A matches the Cell in Column B and sees if the color has changed.
If C.Value = Cel.Value And C.Interior.Color <> RGB(200, 200, 200) Then
'Colors the cell
C.Interior.Color = RGB(200, 200, 200)
'Updates the value in Column A with the cell to the right of the Cell in Column B
C.Value = Cel.Offset(0, 1).Value
End If
Next
Next
'Uncomment the line below to remove color again
'Range("A1:A" & LastRow).Interior.ColorIndex = xlNone
End Sub

Related

Compare two columns from multiple sheets ans extract values

It may be a repeated question, but I couldn't find an effective solution anywhere.
One of my clients needs a weekly update on projects. They download an excel from their ERP consisting of multiple columns and I have to comment status on the last column.
Every week I will get a fresh copy and all my previous entries will be cleared, then its a repeated job for me. I just want to see what I commented last week and copy paste the same in the new sheet.
Problems:
The new sheet will be in a mixed order.
Some new rows will be there and some rows disappear.
Sheet 1
Sheet 2
For the new rows in Sheet 2, I will update the comments manually.
But please help me on copying the repeated rows, which I entered on sheet1
Looking for some expert solutions
Thanks
Try the below code. It worked for me.
Input sheet (Sheet1):
Below is the code:
Sub Comapre()
Dim TotalNames As Integer
Dim NameInSheet2 As String, PO As String
TotalNames = Worksheets("Sheet2").Range("A1").End(xlDown).Row
For i = 2 To TotalNames
NameInSheet2 = Worksheets("Sheet2").Range("A" & i).Value
PO = Worksheets("Sheet2").Range("B" & i).Value
Worksheets("Sheet1").Activate
'Finds the cell value in Sheet1
Set cell = Cells.Find(What:=NameInSheet2, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If cell Is Nothing Then
Else
'If it found the name then it will compare the PO value
If cell.Offset(, 1).Value = PO Then
'If Name and Po value matched then comment will be copied to sheet2.
Worksheets("Sheet2").Range("C" & i) = cell.Offset(, 2).Value
End If
End If
Next
End Sub
Output Sheet(Sheet2):
Please let me know if my answer fits your question.
If I understand you right a simple VLOOKUP() should do the job.
I am assuming the PO numbers in a table are unique.
You take new sheet and look for the last comment you had for this PO.
in the Sheet2 eg in cell C2 you would type like:
=VLOOKUP(B2,Sheet1!B:C,2,FALSE)
This will look up your PO nr 4500253 in the Sheet1 Column B (with an exact match) and return the matched row value from Column C. An error is returned if no match is found.
using Dictionary object
Option Explicit
Sub main()
Dim dict As Object
Dim cell As Range
Set dict = CreateObject("Scripting.Dictionary")
With Worksheets("Sheet1")
For Each cell In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
dict.Item(cell.Value2 & "|" & cell.Offset(, 1).Value2) = cell.Offset(, 2).Value2
Next
End With
With Worksheets("Sheet2")
For Each cell In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
If dict.exists(cell.Value2 & "|" & cell.Offset(, 1).Value2) Then cell.Offset(, 2).Value = dict.Item(cell.Value2 & "|" & cell.Offset(, 1).Value2)
Next
End With
End Sub

Adding a column to a named range based on a cell value

I'm trying to create a macro which will be adding a column to a named range provided on the value in a column next to a named range.
To be more specific, the range B:G is named "Furniture". Depending on the value in the first row of a column next to this range (A or H), I need to add a column to this named range. So if a cell H1 is "Furniture" then column H will be added to the named range "Furniture".
Of course, it has to be a universal method so that every column named "Furniture" next to this range will be added to it.
I'm a complete newbie to VBA, so I created a code attached below for a singular case. However, it doesn't work and, moreover, it's not a general code.
Range("H1").Select
If cell.Value = "Furniture" Then
With Range("Furniture")
.Resize(.Columns.Count + 1).Name = "Furniture"
End With
End If
If you could provide more information about the structure of your sheet, I could help you with a decent loop, because it's not clear how you want to loop through the columns / rows. Can the target range always be found in the first row of every column?
For now, this will help you hopefully, as it dynamically adds columns to a range. The name of the particular range comes from the selected cell.
lastColumn = Range("A1").SpecialCells(xlCellTypeLastCell).Column
For currentColumn = 1 To lastColumn
Cells(1, currentColumn).Activate
If Not IsEmpty(ActiveCell.Value) Then
targetRange = ActiveCell.Value
ActiveCell.EntireColumn.Select
On Error Resume Next
ActiveWorkbook.Names.Add Name:=targetRange, RefersTo:=Range(targetRange & "," & Selection.Address)
If Err <> 0 Then
Debug.Print "Identified range does not exists: " & targetRange
Else
Debug.Print "Identified range found, extended it with " & Selection.Address
End If
End If
Next currentColumn

Excel VBA - For Each loop is not running through each cell

I am currently facing an issue in which my 'for each' loop is not moving onto subsequent cells for each cell in the range I have defined when I try to execute the script. The context around the data is below:
I have 3 columns of data. Column L contains employees, Column K contains managers, and column J contains VPs. Column K & J containing managers and VPs are not fully populated - therefore, I would like to use a VBA script & Index Match to populate all the cells and match employees to managers to VPs.
I have created a reference table in which I have populated all the employees to managers to directors and have named this table "Table 4". I am then using the VBA code below to try and run through each cell in column K to populate managers:
Sub FillVPs()
Dim FillRng As Range, FillRng1 As Range, cell As Range
Set FillRng = Range("J2:J2000")
Set FillRng1 = Range("K2:K2000")
For Each cell In FillRng1
If cell.Value = "" Then
ActiveCell.Formula = _
"=INDEX(Table4[[#All],[MGRS]], MATCH(L583,Table4[[#All],[EMPS]],0))"
End If
Next cell
End Sub
I feel that something is definitely wrong with the index match formula as the match cell "L583" is not moving to the next cell each time it runs through the loop; however, I am not sure how to fix it. I also do not know what else is potentially missing. The code currently executes, but it stays stuck on one cell.
Any help is greatly appreciated, and I will make sure to clarify if necessary. Thank you in advance.
The problem is that you are only setting the formula for the ActiveCell.
ActiveCell.Formula = _
"=INDEX(Table4[[#All],[MGRS]], MATCH(L583,Table4[[#All],[EMPS]],0))"
This should fix it
cell.Formula = _
"=INDEX(Table4[[#All],[MGRS]], MATCH(L583,Table4[[#All],[EMPS]],0))"
You'll probably need to adjust L583. It will not fill correctly unless you are filling across all cell.
These ranges should probably be changed so that they are dynamic.
Set FillRng = Range("J2:J2000")
Set FillRng1 = Range("K2:K2000")
You should apply the formula to all the cells in the range
Range("K2:K2000").Formula = "=INDEX(Table4[[#All],[MGRS]], MATCH(L2,Table4[[#All],[EMPS]],0))"
UPDATE: Dynamic Range
Every table in Excel should have at least one column that contain an entry for every record in the table. This column should be used to define the height of the Dynamic Range.
For instance if Column A always has entries and you want to create a Dynamic Range for Column K
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Set rng1 = Range("K2:K" & lastrow)
Or
Set rng1 = Range("A2:A" & Rows.Count).End(xlUp).Offset(0, 10)
UPDATE:
Use Range.SpecialCells(xlCellTypeBlanks) to target the blank cells. You'll have to add an Error handler because SpecialCells will throw an Error if no blank cells were found.
On Error Resume Next
Set rng1 = Range("A2:A" & Rows.Count).End(xlUp).Offset(0, 10).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If rng1 Is Nothing Then
MsgBox "There were no Blank Cels Found", vbInformation, "Action Cancelled"
Exit Sub
End If
The "L583" was not changing because you were not telling it to. The code below should change the reference as the cell address changes.
Range.Address Property
Sub FillVPs()
Dim FillRng As Range, FillRng1 As Range, cell As Range
Set FillRng = Range("J2:J2000")
Set FillRng1 = Range("K2:K2000")
For Each cell In FillRng1
If cell.Value = "" Then
cell.Formula = _
"=INDEX(Table4[[#All],[MGRS]], MATCH(" & cell.Offset(0,1).Address() & ",Table4[[#All],[EMPS]],0))"
End If
Next cell
End Sub

Copy Yellow Cells in Row 2 of Sheet1 sequentially to Sheet2

I want to search through cells in Row 2 of worksheet "In Motion". If a cell is highlighted yellow, I want to copy the entire column and paste it to worksheet "Dashboard". I want this to repeat to find every yellow cell in row 2 of "In Motion". I also want the columns to paste sequentially onto "Dashboard".
The code I have, which I've built partly from running macros doesn't work. It DOES copy the column of the first yellow cell it finds on "In Motion" and pastes to A1 of "Dashboard". But, it DOES NOT loop through all the cells in row 2. It just stops.
Also, I think if the loop were working, my code wouldn't effectively paste columns sequentially to "Dashboard". I think they'd all be pasting to A1.
Sorry for the noob quesiton. Help is greatly appreciated!
Sub AutoPopulateNew()
Dim C As Range
'Clear Dashboard
Worksheets("Dashboard").Activate
Worksheets("DashBoard").Cells.ClearContents
'Move to In Motion Sheet
Worksheets("In Motion").Activate
'Find and copy yellow highlighted cells
For Each C In Worksheets("In Motion").Rows("2:2")
C.Select
With Application.FindFormat.Interior.Color = 65535
End With
Selection.Find(What:="", LookIn:=xlFormulas, LookAt _
:=xlPart, SearchFormat:=True).Activate
ActiveCell.EntireColumn.Copy _
Destination:=Worksheets("Dashboard").Range("A1")
Next C
Worksheets("Dashboard").Activate
End Sub
You don't need to activate a sheet to write in it. I like to use RGB declaration of colors and(255,255,0) is yellow. You can use vbYellow instead too. To find out the RGB numbe of any color, select the cell, goto the buckets icon that colors the background, choose more colors and then custom to see the RGB numbers. This code will do that, edit as you need.
Sub AutoPopulateNew()
Dim i As Integer
Dim j As Integer
Dim count As Integer
Dim c As Range
'Clear Dashboard sheet
Worksheets("DashBoard").Cells.ClearContents
count = 1 'counts the cells with a matching background color
'Loop through the cells and check if the background color matches
For Each cell In Worksheets("In Motion").Rows(2).Cells
If cell.Interior.Color = RGB(255, 255, 0) Then
Worksheets("Dashboard").Cells(1, count).Value = cell.Value
count = count + 1
End If
Next cell
End Sub
Thanks Ibo for the help! The loop worked going through the highlighted cells.
For what it's worth, I ended up changing my approach to copying and pasting columns based on whether they are marked with "x" in a given row. Code is below if it helps anyone who stumbles here.
Sub AutoPopulateX()
Dim SingleCell As Range
Dim ListofCells As Range
Dim i As Integer
'Clear Dashboard
Worksheets("Dashboard").Activate
Worksheets("DashBoard").Cells.ClearContents
'Move to In Motion and Set Range
Worksheets("In Motion").Activate
Application.Goto Range("a1")
Set ListofCells = Worksheets("In Motion").Range("a2:ba2").Cells
i = 1
Set SingleCell = Worksheets("In Motion").Cells(2, i)
'Loop: search for xyz and copy paste to Dashboard
For Each SingleCell In ListofCells
If InStr(1, SingleCell, "x", 1) > 0 Then
Range(Cells(3, i), Cells(Rows.count, i)).Copy
Worksheets("Dashboard").Paste Destination:=Worksheets("Dashboard").Cells(1, Columns.count).End(xlToLeft).Offset(0, 1)
End If
Application.Goto Range("a1")
i = i + 1
Next SingleCell
'Clean up Dashboard
Worksheets("Dashboard").Columns("a").Delete
Worksheets("Dashboard").Activate
End Sub

Change a cell's format to boldface if the value is over 500

I am using Excel 2010 and trying to add a bunch of rows placing the sum of columns A and B in column C. If the sum is over 500 I would then like to boldface the number in column C. My code below works works mathematically but will not do the bold formatting. Can someone tell me what I am doing wrong? Thank you.
Public Sub addMyRows()
Dim row As Integer 'creates a variable called 'row'
row = 2 'sets row to 2 b/c first row is a title
Do
Cells(row, 3).Formula = "=A" & row & "+B" & row 'the 3 stands for column C.
If ActiveCell.Value > 500 Then Selection.Font.Bold = True
row = row + 1
'loops until it encounters an empty row
Loop Until Len(Cells(row, 1)) = 0
End Sub
Pure VBA approach:
Public Sub AddMyRows()
Dim LRow As Long
Dim Rng As Range, Cell As Range
LRow = Range("A" & Rows.Count).End(xlUp).Row
Set Rng = Range("C2:C" & LRow)
Rng.Formula = "=A2+B2"
For Each Cell In Rng
Cell.Font.Bold = (Cell.Value > 500)
Next Cell
End Sub
Screenshot:
An alternative is conditional formatting.
Hope this helps.
Note: The formula in the block has been edited to reflect #simoco's comment regarding a re-run of the code. This makes the code safer for the times when you need to re-run it. :)