I am trying to search for a "/" in a cell within the first column. I need to go through 13 worksheets, find the cell that contains that "/" (which may also contain other text), and highlight that row. Ive been testing out code I've found online and haven't had much luck in getting through the whole workbook.
Dim value As String
value = "/"
x = 1
For x = 1 To 13 Step -1
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For y = 1 To lastrow
Range("a" & i).Find (value)
Range("a" & i).Rows.Interior.Color = RGB(256, 1, 1)
Next y
Next x
This is the code I'm using. If anyone could offer some assistance I'd greatly appreciate it.
It's irrelevant to your question, but the first thing I noticed was:
For x = 1 To 13 Step -1
This will never work; a negative step will only work if the order of the values is descending.
You're missing any selection of a worksheet. If you are iterating through all worksheets in the workbook, then easiest way to do it is with For each wks in Worksheets.
Find in Excel VBA is a little convoluted. A call to Find returns the first cell in the range that contains the specified text. You then need to make subsequent calls to FindNext to get any other matching cells. But, FindNext will run forever -- you need to save a reference to the first matched cell, then compare the result you get from FindNext until the first matched cell shows up again.
Here's how I would do it:
Sub foo()
Dim value As String: value = "/"
Dim rSearch As Range
Dim firstFound As Range
Dim nextFound As Range
Dim wks As Worksheet
For Each wks In Worksheets
wks.Activate
Set rSearch = Range("a1", Cells(Rows.Count, "a").End(xlUp))
Set firstFound = rSearch.Find(value)
If Not firstFound Is Nothing Then
Set nextFound = firstFound
Do
nextFound.EntireRow.Interior.Color = RGB(256, 1, 1)
Set nextFound = rSearch.FindNext(nextFound)
Loop While nextFound.Address <> firstFound.Address
End If
Next
End Sub
Related
I'm new to vba and I'm struggling with this little problem.
I haven't found any posts dealing with this issue though.
here is the point:
I'd like to fill every cell of a board bellow a range of datas with a specific value.
Let's say I've already got a range of datas in the column A , I'd like, in the same column, the line after the last cell filled with "a" values ( that can vary) fill the next empty cells with a specific value ( "b").
Here is an example of what I'd like to do as a final result;
column A
a
a
a
a
a
a
b
b
b
b
b
I tried to code it but as soon as I launched it nothing happens, nothing changes.
Here it is ;
Sub test()
Dim firstlineb As Long
Dim lastlineEmpty As Long
Dim x As Integer
firstlineb = Worksheets("Sheets1").Range("A2",Range("A2").End(xlDown)).End(xlDown).Offset(1)
lastlineEmpty = Worksheets("Sheets1").Range("A2",Range("A2").End(xlDown)).End(xlDown).Offset(1).End(xlDown)
For x = firstlineb To lastlineEmpty
Cells(x, 1).Value = "b"
Next x
End Sub
I'd heavily appreciate your help. Thank you a lot !
I don't know if I understood your problem correctly but try this :
Sub test()
Dim firstlineb As Range
Dim lastlineEmpty As Range
Dim cel As Range
Set firstlineb = Range("A2").End(xlDown).Offset(1)
Set lastlineEmpty = Range(firstlineb, firstlineb.End(xlDown))
For Each cel In lastlineEmpty.Cells
If cel = "" Then
cel.Value = "b"
Else: Exit Sub
End If
Next cel
End Sub
I think you got lost with the ".End(xlDown)", if you set up the variable as a range you can then use it like a cell :
Range(firstlineb, firstlineb.End(xlDown))
This way you won't have those repetition :
Range("A2",Range("A2").End(xlDown)).End(xlDown).Offset(1).End(xlDown)
Note : I tried the vba on the sheet directly and not in a module, so you'll have to add "Worsheets("Sheet1")" before the range.
I hope that it helped you a bit.
We'll make a couple assumptions:
Columns(1) has the values you want to assess, a
Columns(2) has labels so you can find your last row for end of all data entry, so you know where Columns(1) data needs to extend, b
We want to find the last row of each (untested with explanatory comments):
With Sheets(1)
dim lastValueRow as Long
lastValueRow = .Cells(.Rows.Count, 1).End(xlUp).row 'Columns(1) = Columns("A")
dim lastDescriptionRow as Long
lastDescriptionRow = .Cells(.Rows.Count, 2).End(xlUp).row 'Columns(2) = Columns("B")
'Using the above, you can paste a single value over a range, without needing to loop
.Range(.Cells(lastValueRow+1, 1),.Cells(lastDescriptionRow, 1)).Value = "b"
End With
Is it possible to find a row with 2 criteria?
I'm importing survey anwsers to a worksheet, now I want to find the answers of a specified person
I need to find the row in the worksheet(ImportLimesurvey) that has 2 specified cell values:
In that row:
the value of the C-cell has to be one of the highest value in that column (I used the function Application.WorksheetFunction.Max(rng))
This value means how much of the survey is filled in. The highest value stands in multiple answer-rows. The highest value is different for every survey. (example, if a survey has 7 pages and the participant fills in all pages :the highest value is 7 for that person, but if the person didn't complete that survey, the value could be e.g. 3), So the filter of the highest value is if the participant completed the whole survey.
the value of the L-cell has to be the same as the cell (Worksheets("Dataimport").Range("M2")
M2= accountnumber of the person I need the answers from
The correct row has to be pasted to (Worksheets("Dataimport").Range("A7")
This is my current code:
Dim g As Range
Dim rng As Range
Set rng = Worksheets("ImportLimesurvey").Range("C:C")
d = Application.WorksheetFunction.Max(rng)
With Worksheets("ImportLimesurvey").Range("L:L")
Set g = .Find(Worksheets("Dataimport").Range("M2"), LookIn:=xlValues)
g.Activate
End With
e = Range("C" & (ActiveCell.Row))
If e = d Then
ActiveCell.EntireRow.Copy _
Destination:=Worksheets("Dataimport").Range("A7")
End If
The problem here is that he finds the row with the right account number, but the answer with the C-value isn't always the highest. It picks (logically) just the first row with that accountnumber. So how can I find the row that matches those 2 criteria?
Thanks in advance
P.S. I'm new to VBA so I tried to be as specific as possible but if you need any additional info, just ask for it ;)
dmt32 forom mrexcel.com found a solution.
Link to topic: https://www.mrexcel.com/board/threads/find-row-with-2-criteria.1157983/
His code works fine:
Sub FindMaxValue()
Dim FoundCell As Range, rng As Range
Dim MaxValue As Long
Dim Search As String, FirstAddress As String
Dim wsDataImport As Worksheet, wsImportLimesurvey As Worksheet
With ThisWorkbook
Set wsDataImport = .Worksheets("Dataimport")
Set wsImportLimesurvey = .Worksheets("ImportLimesurvey")
End With
Search = wsDataImport.Range("M2").Value
If Len(Search) = 0 Then Exit Sub
With wsImportLimesurvey
Set FoundCell = .Range("L:L").Find(Search, LookIn:=xlValues, lookat:=xlWhole)
If Not FoundCell Is Nothing Then
FirstAddress = FoundCell.Address
Do
With FoundCell.Offset(, -9)
If .Value > MaxValue Then Set rng = FoundCell: MaxValue = .Value
End With
Set FoundCell = .Range("L:L").FindNext(FoundCell)
If FoundCell Is Nothing Then Exit Do
Loop Until FoundCell.Address = FirstAddress
rng.EntireRow.Copy wsDataImport.Range("A7")
MsgBox Search & Chr(10) & "Record Copied", 64, "Match Found"
Else
MsgBox Search & Chr(10) & "Record Not Found", 48, "Not Found"
End If
End With
End Sub
Still thanks for the tips.
Firstly, Visual Basic conceptual topics is a great read to help in writing 'better' code. The biggest thing I encourage is to use meaningful variable names.
It's much easier to understand your code when you have variable names like HighestCount or TargetSheet etc. rather than names like a or b etc.
The answer to your question is yes.
I would write something like this:
Option Explicit
Public Function HighestSurveyRow(ByVal TargetAccountNumber As Long) As Long
Dim ImportLimeSurveySheet As Worksheet
Set ImportLimeSurveySheet = ThisWorkbook.Sheets("ImportLimeSurvey")
Dim LastRow As Long
Dim TargetRow As Long
Dim SurveyCountArray As Variant
Dim ArrayCounter As Long
With ImportLimeSurveySheet
ArrayCounter = 1
LastRow = .Cells(.Rows.Count, 12).End(xlUp).Row
ReDim SurveyCountArray(1 To LastRow, 1 To 2)
For TargetRow = 1 To LastRow
If .Cells(TargetRow, 12).Value = TargetAccountNumber Then
SurveyCountArray(ArrayCounter, 2) = TargetRow
SurveyCountArray(ArrayCounter, 1) = .Cells(TargetRow, 3).Value
ArrayCounter = ArrayCounter + 1
End If
Next TargetRow
End With
Dim ResultArray(1 To 2) As Variant
Dim ArrayElement As Long
For ArrayElement = 1 To UBound(SurveyCountArray, 1)
If SurveyCountArray(ArrayElement, 1) > ResultArray(1) Then
ResultArray(1) = SurveyCountArray(ArrayElement, 1)
ResultArray(2) = SurveyCountArray(ArrayElement, 2)
End If
Next ArrayElement
HighestSurveyRow = ResultArray(1)
End Function
Sub FindRowForSurveyResults()
With ThisWorkbook.Sheets("DataImport")
.Range("A7").Value = HighestSurveyRow(.Range("M2").Value)
End With
End Sub
It's split into a Function and a Subroutine. The Function executes most of the code and returns the row number. The Sub calls this function and writes this returned value to cell A7 on "DataImport".
The sub can be broken down as follows;
Using a with statement helps reduce code clutter of defining the worksheet twice.
The only thing the sub is doing is assigning a value to cell A7. To get the value it calls the function and assigns the parameter TargetAccountNumber as the value from cell M2.
The function can be broken down into the following steps;
All variables are declared and the target worksheet for the function is set.
The LastRow of column L is found to establish our maximum length of the Array and search range.
The Loop searches from Row 1 to the LastRow and compares the values from column L. If it matches the TargetAccountNumber parameter then the column C value and the row number are stored into the Array.
Once the Loop is done, another Loop is run to find the highest number. The first iteration will always store the first row's data. Each iteration after that compares the values stored in the SurveyCountArray with the current value of ResultArray(1) and if the value is greater, ResultArray(1) is updated with the value, ResultArray(2) is updated with the Row number.
Once the 2nd loop is done, the Row in ResultArray(2) is assigned to the function for the Sub to write to the worksheet.
It can definately be improved and refined to work faster and more efficiently, especially if you have a very large data set, but this should help get you thinking about ways you can use loops and arrays to find data.
Note: There could be duplicate rows for the outcome (say a user submits the same survey 3 times with the same answers), which I haven't tested for - I think this code would return the highest row number that matches the required criteria but could be tweaked to throw an error or message or even write all row numbers to the sheet.
I have a table with numbers from 1 to 10. (Starting from D2 to M2)
Suppose in A1 there is 03/09/2019
AND in B1 there is 06/09/2019
AND in C1 there is Hello
In COLUMN A I have a multiple series of words starting from A3 to A10
Here is an Example of the Excel Table
What I would like to do is: Search for the word Student in Column A, when I find it, get the numbers from A1 --> 3
and A2 --> 6 and write the word Hello that is in C1 in the cells that go to 3 to 6 in the row of the finded word Student
So my output would be like:
This is my code so far:
Dim Cell As Range
Columns("A:A").Select
Set Cell = Selection.Find(What:="Student", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Cell Is Nothing Then
MsgBox "Word not found"
Else
MsgBox "Word found"
End If
Basically I can find the word Student but don't know how to write the word Hello in the cells between 3 to 6
A few notes regarding the code below (not tested!).
1) Always try use worksheet qualifiers when working with VBA. This will allow for cleaner code with less room for unnecessary errors
2) When using .Find method I use LookAt:=xlWhole because if you do not explicitly define this your code will use the last known method that you would have used in Excel. Again, explicit definition leaves less room for error.
3) Try include error handling when you code. This provides “break points” for easier debugging in the future.
4) You can make the below much more dynamic that it currently is. But I'll leave that up to you to learn how to do!
Option Explicit
Sub SearchAndBuild()
Dim rSearch As Range
Dim lDayOne As Long, lDayTwo As Long
Dim lColOne As Long, lColTwo As Long
Dim sHello As String
Dim wsS1 As Worksheet
Dim i As Long
'set the worksheet object
Set wsS1 = ThisWorkbook.Sheets("Sheet1")
'store variables
lDayOne = Day(wsS1.Range("A1").Value)
lDayTwo = Day(wsS1.Range("B1").Value)
sHello = wsS1.Range("C1").Value
'find the student first
Set rSearch = wsS1.Range("A:A").Find(What:="Student", LookAt:=xlWhole)
'error handling
If rSearch Is Nothing Then
MsgBox "Error, could not find Student."
Exit Sub
End If
'now loop forwards to find first date and second date - store column naumbers
'adjust these limits where necessary - can make dynamic
For i = 4 To 13
If wsS1.Cells(2, i).Value = lDayOne Then
lColOne = i
End If
If wsS1.Cells(2, i).Value = lDayTwo Then
lColTwo = i
Exit For
End If
Next i
'now merge the range
wsS1.Range(wsS1.Cells(rSearch.Row, lColOne), wsS1.Cells(rSearch.Row, lColTwo)).Merge
'set the vvalue
wsS1.Cells(rSearch.Row, lColOne).Value = sHello
End Sub
This is just one way to approach the problem. Hopefully this helps your understanding!
No need for a loop here - just find your value and parse the dates. Assuming your value to be found exists in Column A and your table starts in Column D, there is clear relationship between the columns which is Day(date) + 3.
Sub Test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long, Found As Range
Dim date_a As Long, date_b As Long
lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set Found = ws.Range("A2:A" & lr).Find("Student", LookIn:=xlValues)
If Not Found Is Nothing Then
date_a = Day(Range("A1")) + 3
date_b = Day(Range("B1")) + 3
With ws.Range(ws.Cells(Found.Row, date_a), ws.Cells(Found.Row, date_b))
.Merge
.Value = ws.Range("C1")
End With
Else
MsgBox "Value 'Student' Not Found"
End If
End Sub
I've tried this:
Dim ThisRow As Long
Dim FindWhat As String
FindWhat = "Student"
Dim MyStart As Byte
Dim MyEnd As Byte
MyStart = Day(Range("A1").Value) + 3 'we add +3 because starting 1 is in the fourth column
MyEnd = Day(Range("B1").Value) + 3 'we add +3 because starting 1 is in the fourth column
Dim SearchRange As Range
Set SearchRange = Range("A3:A10") 'range of values
With Application.WorksheetFunction
'we first if the value exists with a count.
If .CountIf(SearchRange, FindWhat) > 0 Then 'it means findwhat exists
ThisRow = .Match(FindWhat, Range("A:A"), 0) 'we find row number of value
Range(Cells(ThisRow, MyStart), Cells(ThisRow, MyEnd)).Value = Range("C1").Value
Application.DisplayAlerts = False
Range(Cells(ThisRow, MyStart), Cells(ThisRow, MyEnd)).Merge
Application.DisplayAlerts = True
Else
MsgBox "Value 'Student' Not Found"
End If
End With
Note I've used worksheets function COUNTIF and MATCH. MATCH will find the position of an element in a range, so if you check the whole column, it will tell you the row number. But if it finds nothing, it will rise an error. Easy way to avoid that is, first, counting if the value exists in that range with COUNTIF, and if it does, then you can use MATCH safely
Also, note that because we are using MATCH, this function only finds first coincidence, so if your list of values in column A got duplicates, this method won't work for you!.
I have a data table with column headings. I have a list of column headings that I don't want.
I want to delete the unwanted column headings no matter where they are in the worksheet and the ability for users to add other columns to delete.
I get
run time 91 error
on this line: ws.Rows("1:1").Select.Find(T).EntireColumn.Delete
Sometimes I will get an error in the first loop of the code, sometimes it will be part way through.
I have looked at other posts but the problems have not be related enough for me to problem solve my way through. I tried reading some articles on defining objects. I have been using the msgbox command to make sure the code is finding the values and that seems to be working all the time but it breaks down at the Find command.
Sub DeleteBadHeaders2()
Dim FirstHeading As Range
Set FirstHeading = Worksheets("Headings_To_Delete").Range("a2")
'Worksheet that has all the column headings I want deleted
Dim x As Integer
'x is for the do while loop to individually highlight each cell
Dim y As Long
y = Worksheets("Headings_To_Delete").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
'y acts as the upper bound to the headings to delete column for the while loop
Dim T As Variant
'T acts as a temporary value holder that will be used to delete the proper columns
Dim ws As Worksheet
Set ws = ActiveSheet
x = 0
Do While x < (y - 1)
Worksheets("Headings_To_Delete").Range("a2").Offset(x, 0).Interior.Color = RGB(224, 0, 0)
'Calling the rage as above fixes the active cell problem
Let T = Worksheets("Headings_To_Delete").Range("a2").Offset(x, 0).Value
'MsgBox T & " is found."
ws.Rows("1:1").Select.Find(T).EntireColumn.Select
'for testing switch the last part of the code to EntireColumn.Interior.Color = RGB(0, 225, 0)
x = x + 1
Loop
'The loop is highlighting the cells incrementally based on the first active cell until the upper limit of how many cells are in the column
End Sub
ws.Rows("1:1").Select.Find(T).EntireColumn.Select
should be
ws.Rows(1).Find(T).EntireColumn.Select 'Delete?
Typically though whenever using Find() it's a good idea to check you actually found anything, by testing the return value for Nothing before trying to do anything like Select or Delete.
Also a good idea to be explicit about some of the other parameters in Find, such as lookAt for example.
Something like this:
Sub DeleteBadHeaders()
Dim r As Long, lastRow As Long
Dim T As Variant
Dim ws As Worksheet, wsList As Worksheet, f As Range
Set ws = ActiveSheet
Set wsList = Worksheets("Headings_To_Delete")
lastRow = wsList.Cells(Rows.Count, 1).End(xlUp).Row 'last row
For r = 2 To lastRow
T = wsList.Cells(r, "A").Value
If Len(T) > 0 Then
Set f = ws.Rows(1).Find(what:=T, lookat:=xlWhole)
'check to see if the heading was found
If Not f Is Nothing Then
Debug.Print "Found header '" & T & "' at " & f.Address
f.EntireColumn.Interior.Color = vbRed '<< for testing
'f.EntireColumn.Delete '<< uncomment when done testing
End If 'was found
End If 'any heading
Next r 'next in list
End Sub
I have an excel sheet with around 200 work sheets each containing a list of products sold to a company.
I need to add
A total at the bottom of row D-G where the bottom can be a different value. I.E. E4
below the total a formula based on the total. I.E. if E4 (being the bottom of the above row) is below $999 the display text "samples", if between 1000-3000 then multiply E4 by 2%, 3001-7500 x 5% etc.
I need to be able to add it to the entire workbook easily using vba. Since I must do this to numerous ss it would literally save me 15-20 hours a month.
Edit:
So I have something that seems to be the right path.
Sub Split_Worksheets()
Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String
Set wSheetStart = ActiveSheet
wSheetStart.AutoFilterMode = False
'Set a range variable to the correct item column
Set rRange = Range("A1", Range("A65536").End(xlUp))
'Delete any sheet called "UniqueList"
'Turn off run time errors & delete alert
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("UniqueList").Delete
'Add a sheet called "UniqueList"
Worksheets.Add().Name = "UniqueList"
'Filter the Set range so only a unique list is created
With Worksheets("UniqueList")
rRange.AdvancedFilter xlFilterCopy, , _
Worksheets("UniqueList").Range("A1"), True
'Set a range variable to the unique list, less the heading.
Set rRange = .Range("A3", .Range("A65536").End(x2Up))
End With
On Error Resume Next
With wSheetStart
For Each rCell In rRange
strText = rCell
.Range("A1").AutoFilter 1, strText
Worksheets(strText).Delete
'Add a sheet named as content of rCell
Worksheets.Add().Name = strText
'Copy the visible filtered range _
(default of Copy Method) and leave hidden rows
.UsedRange.Copy Destination:=ActiveSheet.Range("A1")
ActiveSheet.Cells.Columns.AutoFit
Next rCell
End With
With wSheetStart
.AutoFilterMode = False
.Activate
End With
On Error GoTo 0
Application.DisplayAlerts = True
Dim colm As Long, StartRow As Long
Dim EndCell As Range
Dim ws As Worksheet
StartRow = 3
For Each ws In Worksheets
Set EndCell = ws.Cells(Rows.Count, "c").End(xlUp).Offset(1, 1)
If EndCell.Row > StartRow Then EndCell.Resize(, 4).Formula = "=SUM(R" & StartRow & "C:R[-1]C)"
Set EndCell = ws.Cells(Rows.Count, "D").End(xlUp)
If EndCell.Row >= 1000 Then
Range(J2) = Formula = ((EndCell.Row) * (0.05))
Range(J3) = "5% Discount"
ElseIf EndCell.Row >= 3000 Then
Range(J2) = Formula = ((EndCell.Row) * (0.1))
Range(J3) = "10% Discount"
End If
Next ws
End Sub'
Just need to figure out how to display the results and text to the right cells (J2 in this case)
I will supply the logic and all the references you need to put this one together; and will let you try to put it together on your own :). Come back for more help if needed.
You need to loop through all the worksheets in your workbook (Microsoft Tutorial)
You need to find the last row for the given columns (Online tutorial)
You need to use an IF statement to choose which formula to use (MSDN reference)
UPDATE
What's wrong with your code is this line :
Range(J2) = Formula = ((EndCell.Row) * (0.1))
What you're telling the computer is :
Multiply EndCell.Row by 0.1 (which has the number of the row below and to the right of the last cell in column C)
Compare Formula with the result previously obtained
Store the result of that logical expression at the range stored in variable J2
First of all, what you want is to put the result of the equation, and want to change J2 to "J2" so it gets the cell J2, instead of the what's contained in J2 (which has nothing at that point)
Also, you seem to say that you're not getting the right cells, maybe it is caused by this :
Set EndCell = ws.Cells(Rows.Count, "c").End(xlUp).Offset(1, 1)
In that line, you're finding the last cell of column C, but then you select the cell below, and to the right of it.
There are so many things wrong with your code it's hard to say what's not working properly.