I'm setting up a userform to find a company's name. Each company has 10 rows of data. I need the button to select the first row and then stop and only run the findnext if button is clicked again.
Currently my code finds the company's name correctly, but because of the loop it directly select the last row with the company's name. I need it to select the first time the name appears and then findnext only if I click on the button again
Private Sub CommandButton1_Click()
Dim lastrow As Long, i As Long, c As String
Dim mycell As Range
lastrow = Sheets("Rent Roll").Range("A" & Rows.Count).End(xlUp).Row
c = TextBox1.Text
With Sheets("Rent Roll").Range("C5:C" & lastrow)
Set mycell = .Find(what:=c, LookIn:=xlValues)
If Not mycell Is Nothing Then
firstAddress = mycell.Address
Do
mycell.Select
Set mycell = .FindNext(mycell)
Loop While Not mycell Is Nothing And mycell.Address <> firstAddress
Else
MsgBox ("Not Found")
End If
End With
Exit Sub
End Sub
If I enter "Google", it should select the first row and then stop. Then if I click the button again, use findnext and select the next cell with "Google"
You should be able to to something like this:
Private Sub CommandButton1_Click()
Static lastCell As Range '<< static variables preserve values between calls
Static lastTerm As String
Dim ws As Worksheet, rngSrch As Range
Dim lastrow As Long, i As Long, c As String
Dim f As Range, afterCell As Range
Set ws = ThisWorkbook.Worksheets("Rent Roll")
Set rngSrch = ws.Range(ws.Range("C5"), ws.Cells(Rows.Count, "C").End(xlUp))
c = TextBox1.Text
'new search term?
If c <> lastTerm Then
Set lastCell = Nothing
lastTerm = c
End If
If Len(c) = 0 Then Exit Sub '<< nothing to search for
If lastCell Is Nothing Then
Set afterCell = Rng.Cells(Rng.Cells.Count)
Else
Set afterCell = lastCell
End If
Set f = rngSrch.Find(what:=c, after:=afterCell, LookIn:=xlValues)
If f Is Nothing Then
MsgBox ("'" & c & "' not found")
Else
If f.Row < lastCell.Row Then
MsgBox "Already at the last row" '<< do this, or just keep wrapping round?
Else
f.Select
Set lastCell = f
End If
End If
End Sub
Related
I would like to copy the first 5 rows (to cell M7) after applying a filter in the table. I have tried a macro found on the internet, but it does not work in any way in my file.
Sub TopNRows()
Dim i As Long
Dim r As Range
Dim rWC As Range
Set r = Range("B16", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
For Each rWC In r
i = i + 1
If i = 5 Or i = r.Count Then Exit For
Next rWC
Range(r(2), rWC).Resize(, 7).SpecialCells(xlCellTypeVisible).Copy Sheet7.[M7]
End Sub
I tried to customize them, where my table has x rows (I operate dynamically) and 7 columns. The headings are in (B15:H15). However, they do not work all the time. The error pops up for me at
Range(r(2), rWC).Resize(, 7).SpecialCells(xlCellTypeVisible).Copy Sheet7.[M7]
Try the following...
Sub TopNRows()
Dim rng As Range
Dim filt As Range
Dim topRows As Range
Dim currentCell As Range
Dim count As Long
Set rng = Range("B15", Range("B" & Rows.count).End(xlUp))
With rng
On Error Resume Next
Set filt = .Offset(1, 0).Resize(.Rows.count - 1).SpecialCells(xlCellTypeVisible)
If filt Is Nothing Then
MsgBox "No records found!", vbExclamation
Exit Sub
End If
On Error GoTo 0
End With
count = 0
For Each currentCell In filt.Cells
If topRows Is Nothing Then
Set topRows = currentCell
Else
Set topRows = Union(topRows, currentCell)
End If
count = count + 1
If count >= 5 Then Exit For
Next currentCell
topRows.Copy Sheet7.[M7]
End Sub
I have got an excel workbook, it has 5 static tabs and more tabs can be created using a template tab.
In each tab there is a certain field or a range that is mandatory to be filled out also in the new created tabs (might be up to 60).
My question is how can I go about seeing in, lets say in mainsheet, a summary which shows me:
Which tab has missing fields
Which fields is missing (an address of a cell)
I tried naming the range "MyRange" and counting if the cells are non blank.
But this will not work for the newly created sheets.
I also tried a conditional formatting but again this will not give me a summary.
In the meantime I also bumped into a sort of solution but this is also not the thing I am looking for:
Sub listEmptyCells()
Dim emptyAddresses() As String
Dim i As Long
Dim ws As Worksheet
Dim rng As Range
Set ws = Sheets("1.Data Source") ' CHANGE AS NECESSARY
Set rng = ws.Range("B30:B32")
If WorksheetFunction.CountBlank(rng) = 0 Then
MsgBox ("No empty cells in the range")
Exit Sub
End If
emptyAddresses() = Split(rng.SpecialCells(xlCellTypeBlanks).Address, ",")
For i = LBound(emptyAddresses) To UBound(emptyAddresses)
ws.Cells(i + 1, 2).Value = emptyAddresses(i)
Next i
End Sub
Your help and guidance here would be highly appreciated
All the best
Jacek
Here's one approach:
Sub listEmptyCells()
Const CHECK_RANGE As String = "B30:B32" 'range to locate empty cells in
Dim i As Long, r As Long, rngCheck As Range, rngEmpty As Range
Dim ws As Worksheet, wb As Workbook, wsSummary As Worksheet
Dim rwSummary As Range, s As String, c As Range
Set wb = ThisWorkbook
Set wsSummary = wb.Worksheets("Summary")
Set rwSummary = wsSummary.Range("A2:B2") 'first row of results
rwSummary.Resize(wb.Worksheets.Count).Clear 'remove previous results
For i = 1 To wb.Worksheets.Count
Set ws = wb.Worksheets(i)
If ws.Name <> wsSummary.Name Then 'exclude specific sheet(s)
s = ""
Set rngEmpty = Nothing
'which range to check - special case or use default?
Select Case ws.Name
Case "Sheet One": Set rngCheck = ws.Range("A1:A10")
Case "Sheet Two": Set rngCheck = ws.Range("G34:G56,H10")
Case Else: Set rngCheck = ws.Range(CHECK_RANGE) 'default range
End Select
'loop cells in check range
For Each c In rngCheck.Cells
If Len(c.Value) = 0 Then
If rngEmpty Is Nothing Then
Set rngEmpty = c
Else
Set rngEmpty = Application.Union(rngEmpty, c)
End If
End If
Next c
If Not rngEmpty Is Nothing Then
s = rngEmpty.Count & " required cell(s) not filled:" & _
rngEmpty.Address(False, False)
End If
With rwSummary 'record results
.Cells(1).Value = ws.Name
.Cells(2).Value = IIf(s <> "", s, "OK")
.Font.Color = IIf(s <> "", vbRed, vbGreen)
End With
Set rwSummary = rwSummary.Offset(1, 0) 'next summary row
End If
Next i
End Sub
I have a macro that loops through cells of one sheet, looks for that value in another sheet, and then highlights the row if they match. I'd like to add a message box that would pop up if a matching value is not found. I know this is a simple problem, but I'm having trouble figuring out in which loop to put my booleans.
Sub MarkXfer_noX()
Dim rng As Range
Dim rng2 As Range
Set rng = Worksheets("Transferred Routings").UsedRange
Dim i As Integer
Dim j As Integer
Dim ProdCI As String
Dim found As Boolean
Dim intRowCount As Integer
intRowCount = Sheets("Transferred Routings").UsedRange.Rows.count
For i = 2 To intRowCount
If rng.Cells(i, 1) <> "" Then ProdCI = rng.Cells(i, 1) 'get the ProdCI number from column A if not blank
Worksheets("All_ProCI").Activate 'activate main page
Set rng2 = Worksheets("All_ProCI").UsedRange 'select a range on the main page
For j = 2 To rng2.Rows.count 'from row 2 to the end
If rng2.Cells(j, 2) = ProdCI Then 'if the ProdCI in column B matches the one we picked,
Call FillCell(j) 'call a sub in a different module and give it our current row
found = True
Else
found = False
End If
Next
Next
If found = False Then
MsgBox (ProdCI & " not found") 'Display a message if one of the items wasn't found on the main page. Currently has an error where the last one in the list always pops up.
Else
End If
End Sub
Right now it always shows a msgbox with the last value in the range no matter what.
Thanks all, here is the updated working code using the Find function
Sub MarkXfer_Find()
'Re-tooled to use the .Find function instead of looping through each
Dim rng As Range
Dim rng2 As Range
Set rng = Worksheets("Transferred Routings").UsedRange
Dim i As Integer
Dim ProdCI As String
Dim intRowCount As Integer
Dim intRowCount2 As Integer
Dim aCell As Range
intRowCount = Sheets("Transferred Routings").UsedRange.Rows.count
For i = 2 To intRowCount
If rng.Cells(i, 1) <> "" Then ProdCI = rng.Cells(i, 1) 'get the ProdCI number from column A if not blank
Worksheets("All_ProCI").Activate 'activate main page
Set rng2 = Worksheets("All_ProCI").UsedRange 'select a range on the main page
intRowCount2 = Worksheets("All_ProCI").UsedRange.Rows.count
'use the Find function to put a value in aCell
Set aCell = rng2.Range("B1:B" & intRowCount2).Find(What:=ProdCI, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
'MsgBox ProdCI & " found"
Call FillCell(aCell.row)
Else 'If aCell is blank display msgbox
MsgBox "ProdCI """ & ProdCI & """ not found"
End If
Next
End Sub
I'm trying to use VBA in a macro to search for a text string and delete the contents of the column. I previously found this on the website and would like to change it to search columns and delete the text "QA1" while retaining the columns. I hope this makes sense.
LastRow = Cells(Columns.Count, "D").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("D" & i).Value = "D" Then
Range("D" & i).EntireColumn.Delete
End If
Next i
You want to clear the contents of the whole column if one cell contains QA1?
Sub Test()
Dim rCell As Range
With ThisWorkbook.Worksheets("Sheet1").Columns(4)
Set rCell = .Find("QA1", LookIn:=xlValues)
If Not rCell Is Nothing Then
.ClearContents
End If
End With
End Sub
If you want to just clear each instance of QA1 in column D:
Sub Test()
Dim rCell As Range
With ThisWorkbook.Worksheets("Sheet1").Columns(4)
Set rCell = .Find("QA1", LookIn:=xlValues)
If Not rCell Is Nothing Then
Do
rCell.ClearContents
Set rCell = .FindNext(rCell)
Loop While Not rCell Is Nothing
End If
End With
End Sub
Can it be written to look through the entire worksheet and delete QA1
where ever it is found?
All instances of QA1 on sheet:
Sub Test()
Dim rCell As Range
With ThisWorkbook.Worksheets("Sheet1").Cells
Set rCell = .Find("QA1", LookIn:=xlValues)
If Not rCell Is Nothing Then
Do
rCell.ClearContents
Set rCell = .FindNext(rCell)
Loop While Not rCell Is Nothing
End If
End With
End Sub
Edit: Add LookAt:=xlWhole to the Find arguments so it doesn't delete cells containing QA1 and other text (e.g. QA11 or Some text QA1)
This code goes through columns in a specified row and removes the "QA1" if found
Dim LastColumn As Integer
Dim RowNumber As Integer
Dim i As Integer
LastColumn = UsedRange.SpecialCells(xlCellTypeLastCell).Column
RowNumber = 1 'Adjust to your needs
For i = 1 To LastColumn Step 1
Cells(RowNumber, i).Value = Replace(Cells(RowNumber, i).Value, "QA1", "")
Next i
Loops through the used range of the active worksheet, and removes the selected text.
Sub RemoveText()
Dim c As Range
Dim removeStr As String
removeStr = InputBox("Please enter the text to remove")
For Each c In ActiveSheet.UsedRange
If c.Value = removeStr Then c.Delete
Next c
End Sub
I am trying to delete duplicate values in a temporary list based on a value in a combobox. The code below loops through individual rows to check whether a value matches. It is slow.
Dim ws As Worksheet
Dim i As Long
Set ws = Sheets("TempList3")
On Error Resume Next
For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
If Cells(i, 2) <> Sheets("Sheet1").ComboBox2.Value Then
ws.Rows(i).EntireRow.Delete
End If
Next
Is there a way to evaluate the entire column's values against the combobox's value once and then delete all rows on a worksheet. Or perhaps there is a better way?
I used a looping Find function, it deletes the row where the value was found and then it searches again and deletes the next row it finds until it can no longer find the Combo value on the sheet:
Sub find_cell()
Dim find_cell As Range
Set ws = Sheets("TempList3")
stop_loop = False
Do Until stop_loop = True
Set find_cell = ws.Cells.Find(What:=Sheets("Sheet1").ComboBox2.Value, LookAt:=xlWhole)
If Not find_cell Is Nothing Then
ws.Rows(find_cell.Row).EntireRow.Delete
Else
stop_loop = True
End If
Loop
End Sub
Not knowing how many rows you are talking about, I used 10 thousand for my example codes. here are two examples, try the both and see what works best for you.
You can run through the column and unionize the range found, then delete the rows, for example.
See here for example workbook
Sub UnIonRng()
Dim FrstRng As Range
Dim UnIonRng As Range
Dim c As Range, s As String
s = Sheets("Sheet1").ComboBox2
Set FrstRng = Range("B:B").SpecialCells(xlCellTypeConstants, 23)
For Each c In FrstRng.Cells
If c = s Then
If Not UnIonRng Is Nothing Then
Set UnIonRng = Union(UnIonRng, c) 'adds to the range
'MsgBox UnionRng.Address 'remove later
Else
Set UnIonRng = c
End If
End If
Next c
UnIonRng.EntireRow.Delete
End Sub
Or you can try to filter the column B and delete the rows that way:
Sub FilterDeleteRow()
Dim ws As Worksheet
Dim LstRw As Long, Rng As Range, s As String, x
Set ws = Sheets("TempList3")
s = Sheets("Sheet1").ComboBox2
Application.ScreenUpdating = 0
With ws
LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row
x = Application.WorksheetFunction.CountIf(.Range("B:B"), s)
If x > 0 Then
Columns("B:B").AutoFilter Field:=1, Criteria1:=s
Set Rng = .Range("B2:B" & LstRw).SpecialCells(xlCellTypeVisible)
Rng.EntireRow.Delete
.AutoFilterMode = 0
Else: MsgBox "Not Found"
End If
End With
End Sub