The code I have, works, but it is slow and I want to avoid using select.
I have tried something in the line of the following:
Sub PopulateBlastEvents()
Dim wsfr As Worksheet
Dim wsl As Worksheet
Dim BlNumber As String
Dim BSStep As Long
Dim SI As String
Dim Srng As Range
Dim Nrng As Range
Dim Arng As Range
Dim NotF As String
Dim Found As Range
Application.ScreenUpdating = False
NotF = "NO INFO"
BSStep = 1
Set Rrng = Sheets("Blast List").Range("A2:A45")
Set Srng = Sheets("Blast List").Range("E1:R1")
For Each cell In Rrng
If cell <> "" Then
For Each cell2 In Srng
If cell2 <> "" Then
On Error Resume Next
SI = cell.Value
BlNumber = CStr("Blasted " & BSStep)
Set wsfr = Sheets(CStr(BlNumber))
Set wsl = Sheets("Blast List")
With wsfr.Range("A:A")
Set Found = Cells.Find(What:=SI, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Found Is Nothing Then
With wsl.Range("A:A")
Set Found1 = Cells.Find(What:=BlNumber, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).End(xlToRight).Offset(0, 1)
Found1.Value = NotF
End With
Else
With wsl.Range("A:A")
Set Found1 = Cells.Find(What:=BlNumber, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).End(xlToRight).Offset(0, 1)
Found1.Value = Found.Value
End With
End If
End With
End If
Next cell2
BSStep = BSStep + 1
End If
Next cell
Set Arng = ThisWorkbook.Worksheets("Blast List").Range("E3:X3").End(xlDown).Select
Application.ScreenUpdating = True
Columns("A:S").EntireColumn.AutoFit
End Sub
The code does run, but returns no value as the range value "rng" remains at NOTHING even though it is in the sheet where it is looking for the value.
Below is the current code I am using that needs to change:
Sub PopulateBlastEvents()
Dim wsfr As Worksheet
Dim wsl As Worksheet
Dim BlNumber As String
Dim BSStep As Long
Dim SI As String
Dim Srng As Range
Dim Nrng As Range
Dim Rrng As Range
Dim Brng As Range
Dim Arng As Range
Dim NotF As String
Application.ScreenUpdating = False
NotF = "NO INFO"
BSStep = 1
Set Rrng = Sheets("Blast List").Range("A2:A45")
Set Srng = ThisWorkbook.Worksheets("Blast List").Range("E1:R1")
For Each Brng In Rrng.Cells
If Brng <> "" Then
For Each Nrng In Srng.Cells
If Nrng <> "" Then
On Error Resume Next
SI = Nrng.Value
BlNumber = CStr("Blasted " & BSStep)
Set wsfr = ThisWorkbook.Worksheets(CStr(BlNumber))
Set wsl = ThisWorkbook.Worksheets("Blast List")
wsfr.Select
Range("A1").Select
Cells.Find(What:=SI, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
If Err.Description <> "" Then
Sheets("Blast List").Select
Range("A1").Select
Cells.Find(What:=BlNumber, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).End(xlToRight).Offset(0, 1).Select
Selection.Value = NotF
Else
Sheets("Blast List").Select
Range("A1").Select
Cells.Find(What:=BlNumber, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).End(xlToRight).Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
End If
Next Nrng
BSStep = BSStep + 1
End If
Next Brng
Set Arng = ThisWorkbook.Worksheets("Blast List").Range("E3:X3").End(xlDown).Select
Application.ScreenUpdating = True
Columns("A:X").EntireColumn.AutoFit
End Sub
I really want to speed up the code and all previous questions I have posted, I was informed not to or avoid using Select.
Please could someone help.
Related
I'm new to VBA code. Attempting to Fill values for filtered range in a particular column ("M") and below code is attempted
Dim prg_type As String
Dim header_name As String
Dim MyColumnNumber As Integer
Dim aCell As Range
Dim i As Integer
Dim c As Excel.Range
For i = 1 To 7
header_name = ActiveWorkbook.Worksheets("Execution").Cells(i + 3, 2).Text
prg_type = ActiveWorkbook.Worksheets("Execution").Cells(i + 3, 3).Text
Sheets("Raw Data").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFilter
Set aCell = ActiveWorkbook.Worksheets("Raw Data").Rows(1).Find(What:="program_type", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
MyColumnNumber = aCell.Column
ActiveSheet. Range("$A$1:$M$300000").AutoFilter Field:=MyColumnNumber, Criteria1:="="
Set aCell = ActiveWorkbook.Worksheets("Raw Data").Rows(1).Find(What:=header_name, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
MyColumnNumber = aCell.Column
ActiveSheet.Range("$A$1:$M$300000").AutoFilter Field:=MyColumnNumber, Criteria1:="1"
For Each c In Range("M2:M" & Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
If c.Offset(, -1).Value = vbNullString Then Exit For
c.Value = prg_type
Next
ActiveWorkbook.Worksheets("Raw Data").AutoFilterMode = False
ActiveWorkbook.Worksheets("Raw Data").Range("A1").Select
Next i
Since I'm using for loop, It's executing for ever for just 25K rows of data. Can I know better way to handle?
I'm trying to paste the enire row of information to the next available row but I keep getting errors about not having the Rows(lastrow +1, 1).EntireRow.Paste written correctly. Please let me know how I can perform that action correctly.
Private Sub CommandButton1_Click()
Dim myValue As String
myEmp = InputBox("Search for an employee by last name")
Range("B3").Value = myEmp
With Sheet7
Range("B:B").Select
Set Row = Selection.Find(What:=myEmp, After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Row.EntireRow.Copy
End With
Worksheets("Employee Reports").Activate
Dim lastrow As Long
lastrow = Range("A65536").End(xlUp).Row
Rows(lastrow + 1, 1).EntireRow.Paste
End Sub
Private Sub Workbook_Open()
Application.EnableEvents = False
Worksheets("Sheet3").Range("A4:A20").Value = ""
End Sub
Private Sub CommandButton1_Click()
Dim myValue As String
myEmp = InputBox("Search for an employee by last name")
ActiveSheet.Range("B3").Value = myEmp
Dim lastrow As Long
lastrow = Worksheets("Employee Reports").Range("A65536").End(xlUp).Row
With Sheet7
Dim rw As Range
Set rw = .Range("B:B").Find(What:=myEmp, After:=.Range("B1"), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not rw Is Nothing Then
rw.EntireRow.Copy Worksheets("Employee Reports").Cells(lastrow + 1, 1)
Else
MsgBox myEmp & " Not Found in Range"
End If
End With
End Sub
I have the following code that Loops and searches through a range of sheets and copies and pastes to a "Blast List" sheet as it finds the correct values:
Sub CopySingle()
Dim wsfr As Worksheet
Dim wsl As Worksheet
Dim BlNumber As String
Dim BSStep As Long
Dim SI As String
Dim Srng As Range
Dim Nrng As Range
Dim Rrng As Range
Dim Brng As Range
Dim Arng As Range
Application.ScreenUpdating = False
BSStep = 1
Set Rrng = ThisWorkbook.Worksheets("Blast List").Range("A3", Range("A3").End(xlDown))
Set Srng = ThisWorkbook.Worksheets("Blast List").Range("E1:Q1")
For Each Brng In Rrng.Cells
For Each Nrng In Srng.Cells
On Error Resume Next
SI = Nrng.Value
BlNumber = CStr("Blasted " & BSStep)
Set wsfr = ThisWorkbook.Worksheets(CStr(BlNumber))
Set wsl = ThisWorkbook.Worksheets("Blast List")
wsfr.Select
Range("A1").Select
Cells.Find(What:=SI, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
Sheets("Blast List").Select
Range("A1").Select
Cells.Find(What:=BlNumber, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).End(xlToRight).Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next Nrng
BSStep = BSStep + 1
Next Brng
Application.ScreenUpdating = True
End Sub
I am now trying to figure out how to adapt the code that if the value is not found, it will put the text "NO INFORMATION" in red in the cell.
Any and all help appreciated.
Regards
I am using this loop to look for values. .Find works but findNext does not, ommiting many values. Here I drop my code, do you have any advice? thank you very much!!
For Each ws In SourceWb.Worksheets
If IsNumeric(Left(ws.Name, 3)) Then
Set gCell = ws.Columns(6).Find(what:=numdoc, LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, searchformat:=False)
If Not gCell Is Nothing And IsNumeric(Left(gCell.Parent.Name, 3)) Then
firstAddress = gCell.Address
Do
repetidos = repetidos + 1
finalcell = gCell.Address
'merged cells code here not displayed
oldaddress = gCell.Address
'>Having trouble here> **
Set gCell = ws.Columns(6).FindNext(after:=gCell)
'**
Loop Until gCell.Address = oldaddress
End If
End If
Next ws
This was the best I could derive from your clues:
Option Explicit
Sub Test()
Dim WS As Worksheet
Dim SourceWB As Workbook
Dim numdoc As Long
Dim gCell As Range
Dim firstAddress As String
Dim oldaddress As String
Dim finalcell As String
Dim repetidos As Long
Set SourceWB = ThisWorkbook 'added for clarity and safety
numdoc = 456
For Each WS In SourceWB.Worksheets
If IsNumeric(Left(WS.Name, 3)) Then 'OK I had to save it as "123 A"
Set gCell = WS.Columns(6).Find(what:=numdoc, _
LookIn:=xlValues, _
lookat:=xlWhole, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
searchformat:=False)
If Not gCell Is Nothing And IsNumeric(Left(gCell.Parent.Name, 3)) Then
firstAddress = gCell.Address
Set gCell = WS.Columns(6).FindNext(after:=gCell)
Do
repetidos = repetidos + 1
finalcell = gCell.Address
'merged cells code here not displayed
oldaddress = gCell.Address
Loop Until gCell.Address = oldaddress
End If
End If
Next WS
End Sub
Not sure if it answers the question but, it does demonstrate indentation.
There's probably room for a With...End With in there but I'm too tired to look for it.
This seems to work at this point.
For Each WS In SourceWB.Worksheets
With ws.Range("F:F")
If IsNumeric(Left(WS.Name, 3)) Then 'OK I had to save it as "123 A"
Set gCell = .Find(what:=numdoc, _
LookIn:=xlValues, _
lookat:=xlWhole, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
searchformat:=False)
If Not gCell Is Nothing And IsNumeric(Left(gCell.Parent.Name, 3)) Then
firstAddress = gCell.Address
Set gCell = .FindNext(after:=gCell)
Do
'merged cells code here not displayed
Loop While Not gCell Is Nothing And gCell.Address <> firstAddress
End If
End If
end with
Next WS
I want to search/find value in textbox2 in an active sheet using command button
Here is my code:
Dim ws As Worksheet
Set ws = Worksheets("FSS-TEM-00025")
Dim FindString As String
Dim Rng As Range
FindString = Me.TextBox2.Value
If Trim(FindString) <> "" Then
With ws.Range("A1:Z1048576")
'Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)'
Set Rng = ws.Cells.Find(What:=FindString, SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
If Not Rng Is Nothing Then
Application.Goto Rng, True
Else
MsgBox "Nothing found"
End If
End With
End If
Unload Me
Try this. This works for me
Option Explicit
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim FindString As String
Dim Rng As Range
Set ws = ThisWorkbook.Worksheets("FSS-TEM-00025")
FindString = TextBox2.Value
If Trim(FindString) <> "" Then
Set Rng = ws.Cells.Find( _
What:=FindString, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
Else
MsgBox "Nothing found"
End If
End If
End Sub
Change LookAt:=xlPart to LookAt:=xlWhole if you are trying to find a complete match.
More on .Find here.