Replace data in an Excel file using macros - vba

I have an Excel file which contains some data in a 2d array.
What I want to do is to create a macro which can replace the asterisk '*' by the header of the column of the table (toto, or tata, or titi).

Like this?
Option Explicit
Sub Sample()
Dim oRange As Range, aCell As Range, bCell As Range
Dim ws As Worksheet
Dim ExitLoop As Boolean
On Error GoTo Whoa
'~~> Change this to the relevant sheet name
Set ws = Worksheets("Sheet1")
Set oRange = ws.Cells
Set aCell = oRange.Find(What:="~*", LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
'~~> Assuming that the headers are in row 2
aCell.Value = Cells(2, aCell.Column)
Do While ExitLoop = False
Set aCell = oRange.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
'~~> Assuming that the headers are in row 2
aCell.Value = Cells(2, aCell.Column)
Else
ExitLoop = True
End If
Loop
End If
Exit Sub
Whoa:
MsgBox Err.Description
End Sub

Using just worksheet tools (no VBA):
Ctrl-F
Find what = ~*
Find All
Ctrl-A to select all the Find results
Close the Find dialog
Assuming your headers in row two, and assuming the cursor lands in column C somewhere (mine did twice, YMMV), type
formula =C$2
Press Ctrl-Enter

Here is a simple way I came up with.
i = 3
While Cells(2, i).Value <> ""
Range(Cells(3, i), Cells(6, i)).Select
Selection.Replace What:="~*", Replacement:=Cells(2, i).Value, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
i = i + 1
Wend
Cells(x,y): x refers to row, y refers to column.
A more refined range select can be used instead of this basic one to have the code choose the appropriate range.
To implement in excel simply open up the code window and paste this code in the desired macro/subroutine.

Related

VBA run code after user selects option from dynamic Form Control Combobox

I have an excel workbook where an unknown amount of data from text files can be imported (the user will import as many text files as they feel necessary). I am attaching an identifier (1, 2, 3, etc) each time a text file is imported to the workbook. On the "Information Sheet" I have a form control combobox where the user selects the "initial data set" aka (1, 2, 3, etc) by selecting the identifier value from the dropdown. What I want to happen is when the user selects a value to specify the initial data set, this data set will get highlighted in grey on the "Data Importation Sheet" aka the sheet where all the data gets imported to. I think my code is close but it isnt working.
Here is my code for the Combobox:
Private Sub ComboBox1_Change()
Call Find_Initial_Data_Set
End Sub
And here is my code for highlighting the data in the "Data Importation Sheet" according to the value in cell E12 where my Combobox is located:
Sub Find_Initial_Data_Set()
Dim ws As Worksheet
Dim aCell As Range
Dim aCell1, aCell2, aCell3 As Range
Dim NewRange As Range
Dim A As String
Dim LastRow As Integer
Worksheets("Information Sheet").Activate
If Range("E12").Value <> "" Then
Set ws = Worksheets("Data Importation Sheet")
A = Worksheets("Information Sheet").Range("E12").Value
Worksheets("Data Importation Sheet").Activate
With ws
Set aCell = .Rows(1).Find(What:=A, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
End With
LastRow = Worksheets("Data Importation Sheet").Cells(Rows.Count, "A").End(xlUp).Offset(-1).Row
With ws
Set aCell1 = aCell.Offset(0, -1)
Set aCell2 = aCell.Offset(LastRow, 5)
Debug.Print aCell1.FormulaR1C1
Debug.Print aCell2.FormulaR1C1
Set NewRange = .Range(aCell1.Address & ":" & aCell2.Address)
Debug.Print NewRange.Address
End With
NewRange.Interior.ColorIndex = 15
Else
End If
End Sub
Here are some visuals of my excel book:
Data Importation Sheet where the data gets input (you cannot see the identifier in this pic but beneath the data I have a cell that says Identifier with the corresponding importation value beside it):
Information Sheet where the user selects the initial data set based on identifier:
And this is what I would like the Data Importation Sheet to look like after the user selects 1 (for example) for the initial data set:
Any advice would be greatly appreciated!
the code would be like this.
sheet's code
Private Sub ComboBox1_Change()
Call Find_Initial_Data_Set(ComboBox1.Text)
End Sub
module code
Sub Find_Initial_Data_Set(A As String)
Dim Ws As Worksheet
Dim aCell As Range, NewRange As Range
Dim LastRow As Integer
Set Ws = Worksheets("Data Importation Sheet")
With Ws
If A <> "" Then
Set aCell = .Rows(1).Find(what:=A, after:=.Range("a1"), LookIn:=xlValues, lookat:=xlPart)
If aCell Is Nothing Then
Else
Set aCell = aCell.Offset(, -1)
LastRow = .Range("a" & Rows.Count).End(xlUp).Row
Set NewRange = aCell.Resize(LastRow, 7)
NewRange.Interior.ColorIndex = 15
End If
End If
End With
End Sub
i rewrote your code somewhat
please single-step through code using F8 key
check if correct ranges are "selected" at "debug" lines
please update your post with findings
i suspect that the wrong cells are being referenced once the worksheet is partially populated
also, please refrain from using: ( ... this means, anyone reading this)
With ws
Set aCell = .Rows(1).Find(What:=A, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
End With
use this:
Set aCell = ws.Rows(1).Find(What:=A, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
it is shorter and more readable
use "with" convention only if it really simplifies the code a lot
see the end of the code for info that may help you
Sub Find_Initial_Data_Set()
Dim infoSht As Worksheet
Dim dataImpSht As Worksheet
Dim aCell As Range
' Dim aCell1, aCell2 As Range ' do not use ... aCell1 is declared as variant. not as range
Dim aCell1 As Range, aCell2 As Range, aCell3 As Range
Dim NewRange As Range
Dim A As String
Dim LastRow As Integer
Set dataImpSht = Worksheets("Data Importation Sheet")
Set infoSht = Worksheets("Information Sheet")
A = infoSht.Range("E12").Value
If A <> "" Then
Set aCell = dataImpSht.Rows(1).Find(What:=A, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
dataImpSht.Activate ' debug .Select command fails if sheet is not visible
aCell.Select ' debug (this should highlight "aCell")
dataImpSht.Cells(dataImpSht.Rows.Count, "A").Select ' debug
dataImpSht.Cells(dataImpSht.Rows.Count, "A").End(xlUp).Select ' debug
dataImpSht.Cells(dataImpSht.Rows.Count, "A").End(xlUp).Offset(-1).Select ' debug
dataImpSht.Cells(dataImpSht.Rows.Count, "A").End(xlUp).Offset(1).Select ' debug
LastRow = dataImpSht.Cells(dataImpSht.Rows.Count, "A").End(xlUp).Offset(-1).Row
aCell.Select ' debug
aCell.Offset(0, -1).Select ' debug
aCell.Offset(LastRow, 5).Select ' debug
Set aCell1 = aCell.Offset(0, -1)
Set aCell2 = aCell.Offset(LastRow, 5)
aCell1.Select ' debug
aCell2.Select ' debug
Debug.Print aCell1.FormulaR1C1
Debug.Print aCell2.FormulaR1C1
Set NewRange = dataImpSht.Range(aCell1.Address & ":" & aCell2.Address)
NewRange.Select ' debug
Debug.Print NewRange.Address
NewRange.Interior.ColorIndex = 15
End If
'---------------------------------------------------------------------------
' check this out ... it may be what you need to use
Dim aaa As Range
Set aaa = dataImpSht.Cells(dataImpSht.Rows.Count, "A").End(xlUp).Offset(1)
aaa.Select
aaa.Range("a1").Select ' aaa can be thought off as the new top left corner
aaa.Range("b2").Select ' you can refer to cells in relation to aaa
Set aaa = aaa.Offset(4) ' and move position of aaa for each iteration
aaa.Range("a1").Select
aaa.Range("b2").Select
'---------------------------------------------------------------------------
End Sub
You need to change LastRow to the following as all you need is the row number:
LastRow = Worksheets("Data Importation Sheet").Cells(Rows.Count, "A").End(xlUp).Row - 1

How to select a date with a set cell color in Excel?

I am trying to create a macro in excel VBA, that searches the Range (B1:B30) of the value of the ActiveCell in Column “B” by a loop. Along with the search of Column, I also want to check if the date’s cell is colored with a particular color. If the date's cell equals the set color "Good", then I want it to change the color of the cell in Column H of the same row as selected to red.
When I run the code, I get an error message of “Run-time error ‘424’: Object required.” When I go to debug the problem, it highlights the .Find function I have and points to the last line of the search which is “SearchFormat:=False).Activate” What should I do to fix this problem?
Any improvement with my overall code will be very much appreciated.
Sub Find()
Dim FirstAddress As String
Dim MySearch As Variant
Dim Rng As Range
Dim I As Long
MySearch = Array(ActiveCell)
With Sheets("Sheet1").Range("B1:B30")
For I = LBound(MySearch) To UBound(MySearch)
Set Rng = .Find(What:=MySearch(I), _
After:=ActiveCell, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
SearchFormat:=False).Activate
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
If ActiveCell.Style.Name = "Good" Then
Rng("H" & ActiveCell.Row).Select
Rng.Interior.ColorIndex = xlColorIndexRed
End If
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
End Sub
Showing the Debug mode of the run-time error.
Screenshot of the Spreadsheet for reference
Code Review:
You have several problems here.
MySearch = Array(ActiveCell) will always be a single value. So why bother looping through it
You cannot set a range to equal range.activate. Searching Sheets("Sheet1").Range("B1:B30") implies that you are searching a worksheet other that the ActiveSheet. If this is the case than .Find(After:=Activecell) suggests that you are looking for a value after the ActiveCell of another worksheet.
Set Rng = .Find(What:=MySearch(I), _
After:=ActiveCell, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
SearchFormat:=False).Activate
Rng("H" & ActiveCell.Row) Rng is a Range object. It doesn't work like Range. You cannot pass it a cell address. You can do this Rng(1,"H") which is really shorthand for Rng.cells(1,"H") bit that is misleading because Rng is in column 2 Rng(1,"H") will reference the value in column I.
Sub Find()
Dim FirstAddress As String
Dim MySearch As Variant
Dim Rng As Range
Dim I As Long
MySearch = ActiveCell 'This is the ActiveCell of the ActiveSheet not necessarily Sheets("Sheet1")
With Sheets("Sheet1").Range("B1:B30")
Set Rng = .Find(What:=MySearch, _
After:=.Range("B1"), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
SearchFormat:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
If Rng.Style.Name = "Good" Then
.Range("H" & Rng.Row).Interior.ColorIndex = xlColorIndexRed
End If
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
End With
End Sub
UPDATE:
Here is the actual answer to your question:
Sub FindMatchingValue()
Const AllUsedCellsColumnB = False
Dim rFound As Range, SearchRange As Range
If AllUsedCellsColumnB Then
Set SearchRange = Range("B1", Range("B" & Rows.count).End(xlUp))
Else
Set SearchRange = Range("B1:B30")
End If
If Intersect(SearchRange, ActiveCell) Is Nothing Then
SearchRange.Select
MsgBox "You must select a cell in the highlighted area before continuing", vbInformation, "Action Cancelled"
Exit Sub
End If
Set rFound = SearchRange.Find(What:=ActiveCell.Value, _
After:=ActiveCell, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
SearchFormat:=False)
If Not rFound Is Nothing Then
Do
If rFound.Style.Name = "Good" Then
Range("H" & rFound.Row).Interior.Color = vbRed
End If
Set rFound = SearchRange.FindNext(rFound)
Loop While Not rFound Is Nothing And rFound.Address <> ActiveCell.Address
End If
End Sub
You can't put Activate at the end of the findthe way you are trying to do.
Try this as you find statement.
Set Rng = .Find(What:=MySearch(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
Rng.Activate
Then if you want to Activate the range, do that. But, it is best to stay away from Select, Activate etc in VBA code. I strongly suggest not using that last line of code and adjust you code to not rely on Select and Activate.
you may want to consider an Autofilter approach so as to loop only through relevant cells, as follows:
Option Explicit
Sub Find()
Dim cell As Range
With Sheets("Sheet1").Range("B1:B30")
.Rows(1).Insert '<--| insert a dummy header cell to exploit Autofilter. it'll be removed by the end
With .Offset(-1).Resize(.Rows.Count + 1) '<--| consider the range expanded up to the dummy header cell
.Rows(1) = "header" '<--| give the dummy header cell a dummy name
.AutoFilter field:=1, Criteria1:=ActiveCell '<--| filter range on the wanted criteria
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any cell other than "header" one has been filtered...
For Each cell In .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) '<--| ... loop through filtered cells only
If cell.Style.Name = "Good" Then cell.Offset(, 6).Interior.ColorIndex = 3 '<--| ... and color only properly styled cells
Next cell
End If
.AutoFilter '<--| .. show all rows back...
End With
.Offset(-1).Resize(1).Delete '<--|delete dummy header cell
End With
End Sub

VBA for cut Data for certain Keywords

I want cut data from A1:D10000 for certain keyword. Example if have any string with "Release Date:\n "it will be cut & paste in corresponding cell in F column.
I mean if any string have with "Release Date:\n " in C21 then it will be cut & paste in F21
I have a code & it works fine. But problem is it needs huge time to complete than i expected. Any better code as if it runs quickly?
My Code:
Sub Macro87()
For Repeat = 1 To 10000
Dim found As Range
Sheets("part15").Select
Range("A1").Select
Columns("A:D").EntireColumn.Select
Set found = Selection.Find(What:="Release Date:\n ", After:=ActiveCell, LookIn:= _
xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _
, MatchCase:=False, SearchFormat:=False)
If Not found Is Nothing Then
found.Select
ActiveCell.Select
Selection.Cut
Range("F" & (ActiveCell.Row)).Select
ActiveSheet.Paste
Set found = Nothing
End If
Next
End Sub
Firstly, stop going from 1 to 10,000 - you don't need to repeat the action so much when you can use .FindNext instead. Secondly, avoid like the plague the use of .Select.
Dim ws as Worksheet
Set ws = ThisWorkbook.Worksheets("part15")
Dim lastRow
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Dim found As Range
With ws.Range("A:D")
Set found = .Find(What:="Release Date:\n ", After:=ActiveCell, LookIn:= _
xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _
, MatchCase:=False, SearchFormat:=False)
If Not found Is Nothing Then
firstAddress = found.Address
Do
ws.Range("F" & found.Row).Value = found.Value
set found = .FindNext(found)
Loop While Not found Is Nothing And found.Address <> firstAddress
End If
End With
End Sub
As Dave mentioned, much of your slow down is going to come from the repeated select statements in your code. VBA usually does not need to select a range in order to work with the data therein. The following should speed things up for you quite a bit. It runs for me instantaneously:
Sub Macro87()
Set Rng = Range("A1:D10000")
For Each cel In Rng
If InStr(1, cel.Value, "Release Date:\n ") > 0 Then
Cells(cel.Row(), 6) = cel.Value
cel.Value = Empty
End If
Next cel
End Sub

How to reset FIND function result before looping to another sheet?

I would like to ask if you can help with the code below. On every sheet in my workbook there is the same kind of a table, however on each sheet the table has different location and values. I need to go through all sheets, search for table values on every sheet and then do some other operations with the values. I use Find function to determine header of the table and subsequently table range. The Find function does not work properly though as it keeps found address of "Header" cell from the first sheet for every other sheet. Is there any way to reset the found header address value before looping to another sheet? Thank you in advance.
Sub FindInDynamicRanges()
Dim wb1 As Workbook
Dim ws As Worksheet
Dim FoundCell, FoundTab, TabEntries As Excel.Range
Dim FirstAddr As String
Dim FirstRow, LastRow As Long
Set wb1 = ThisWorkbook
'Find all occurences of any table value on all sheets in dynamic ranges
For Each ws In wb1.Worksheets
Set ws = ActiveSheet
'Find "Header" cell
Set FoundCell = ws.Columns(2).Find(What:="Header", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
MsgBox FoundCell.Address
'Set number of first entry row and last entry row
FirstRow = FoundCell.Row + 1
LastRow = ws.Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, LookIn:=xlValues, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False).Row
ws.Range("B" & FirstRow & ":B" & LastRow).Name = "TabEntries"
MsgBox Range("TabEntries").Address
With ws.Range("TabEntries")
Set LastCell = .Cells(.Cells.Count)
End With
Set FoundTab = ws.Range("TabEntries").Find(What:="*", After:=LastCell, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not FoundTab Is Nothing Then
FirstAddr = FoundTab.Address
End If
Do Until FoundTab Is Nothing
'do some staff with found values
Set FoundTab = ws.Range("TabEntries").FindNext(After:=FoundTab)
If FoundTab.Address = FirstAddr Then
Exit Do
End If
Loop
Next ws
End Sub
as it keeps found address of "Header" cell from the first sheet for every other sheet.
That is because you are telling it to...
For Each ws In wb1.Worksheets
Set ws = ActiveSheet
You don't need that Set ws = ActiveSheet
When you say For Each ws, the ws is automatically initialized. So just remove the second line.

Find a Column ("name") and Fill down with Formula

Sheets("DATA").Rows(2).Find(What:="Apple", LookIn:=xlValues, _
LookAt:=xlWhole).Offset(1, 0).Value = "=A3-B3"
Selection.FillDown
I want to find a column "Apple" in Row 2 and filldown with formula "A3-B3"
Would something like .value="=A3-B3".filldown work?
Thanks!
Further to my comments above, try this. I have commented the code. Do let me know if you find anything confusing...
Sub Sample()
Dim ws As Worksheet
Dim LRow As Long
Dim aCell As Range
'~~> Set this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Data")
With ws
'~~> Find Last Row
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Find the cell which has "Apple"
Set aCell = .Rows(2).Find(What:="Apple", LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'~~> if found, then enter the formula till the last row IN ONE GO
If Not aCell Is Nothing Then
.Range(.Cells(3, aCell.Column), .Cells(LRow, aCell.Column)).Formula = "=A3-B3"
End If
End With
End Sub