Trying to automate a lengthy data entry process in excel.
For some reason the second time I try to find a value in a given range I get a run time 91 error. I can't figure out why this is happening. If I change the range from "AF3:AF30" to the first time I set a range("B2:AD2"), the program will continue through the line with no problem. But for some reason any range other than the first "B2:AD2" will give runtime!
Code:
Sub AutoFill()
Range("B8:AD57").Select
Selection.ClearContents
Range("B8").Select
Dim Rng As Range, cell As Range
Set Rng = Worksheets("Avon Trailer List").Range("E4:E38")
For Each cell In Rng
Dim temp As String
temp = Replace(cell.Value(), " ", "")
temp = Replace(temp, "+", "")
If temp = "" Then
Exit For
Else
col = ""
tempa = SplitMultiDelims(temp, "/,\)(")
For i = 0 To UBound(tempa)
If InStr(tempa(i), "A") = 1 Then
strInput = Worksheets("Pallet Check").Range("B2:AD2").Find(tempa(i)).Address()
lnRow = Range(strInput).Row
strCol = Left(strInput, Len(strInput) - Len(CStr(lnRow)))
strCol = Replace(strCol, "S", "")
Search = tempa(i)
ElseIf InStr(tempa(i), "A") > 1 Or InStr(tempa(i), "B") > 1 Or InStr(tempa(i), "a") > 1 Or InStr(tempa(i), "b") > 1 Then
strInput = Worksheets("Pallet Check").Range("AF3:AF30").Find(Search).Address()
lnRow = Range(strInput).Row
Range("AH" & lnRow).Value() = "(" & tempa(i) & ")"
ElseIf tempa(i) <> "" Then
Worksheets("Pallet Check").Range(strCol & tempa(i) + 7).Value() = Worksheets("Pallet Check").Range(strCol & tempa(i) + 7).Value() & tempa(i)
End If
Next i
End If
Next cell
End Sub
Runtime Error 91 happens on the following line of code:
strInput = Worksheets("Pallet Check").Range("AF3:AF30").Find(Search).Address()
Find().Address breaks with exception (code 91) if not found. This is because .Find() returns a range that actually points to one specific cell OR returns Nothing when not found and 'Nothing'.Address is meaningless (n.b.: null value for objects in VBA is 'Nothing'). So I would replace that line with
Fnd = Worksheets("Pallet Check").Range("AF3:AF30").Find(Search)
if Not Fnd Is Nothing then
strInput = Fnd.Address
...
Related
I'm having a bit of trouble with this and I'm not sure why...
My code (such that it is, a work in progress) is getting stuck on this line:
Set starRange = .Range(Cells(title), Cells(LR, 3))
Can I not use a range variable to set a new range in this way?
Sub cellPainter()
Dim ws As Worksheet
Dim starRange, titleRange, found As Range
Dim errorList() As String
Dim i, LR As Integer
i = 0
ReDim errorList(i)
errorList(i) = ""
For Each ws In ActiveWorkbook.Worksheets
With ws
LR = .Cells(.Rows.Count, "C").End(xlUp).Row
Set titleRange = .Range("C4")
If InStr(1, titleRange, "Title", vbBinaryCompare) < 1 Then
Set found = .Range("C:C").Find("Title", LookIn:=xlValues)
If Not found Is Nothing Then
titleRange = found
Else
errorList(i) = ws.Name
i = i + 1
ReDim Preserve errorList(i)
End If
End If
Set starRange = .Range(Cells(titleRange), Cells(LR, 3))
For Each cell In starRange
If InStr(1, cell, "*", vbTextCompare) > 0 Then Range(cell, cell.Offset(0, 2)).Interior.ColorIndex = 40
If InStr(1, cell, "*", vbTextCompare) = 0 Then Range(cell, cell.Offset(0, 2)).Interior.ColorIndex = 0
Next cell
End With
Next ws
If errorList(0) <> "" Then
txt = MsgBox("The following worksheets were missing the Title row, and no colour changes could be made:" & vbNewLine)
For j = 0 To i
txt = txt & vbCrLf & errorList(j)
Next j
MsgBox txt
End If
End Sub
Edit:
Rory cracked it!
When using a variable inside Range, the Cells property is not required:
Set starRange = .Range(titleRange, .Cells(LR, 3))
First off, ill give credit where credit is due. This is put together using code from u/Joe Was from Mr.Excel.com and exceltip.com.
Now that I have gotten that out of the way I am trying to create a search function that will search through my 9 sheet document in excel, to find a value that was typed into a search box. Then paste those values onto the first page of the workbook.
What do I need to change in my code to make it paste to the right place on the search page? I have tried changing things in the last loop because that is where I get the "Run-Time error 91. Object variable or with block variable not set".
I've googled that error, but variables always screw me up so that may be the problem.
The search page.
This is where the Debugger stops.
This is my code so far.
Sub Find_one()
'Find Function For ERF Spreadsheet'
'Type in Box, Press Button, Display the Results'
Dim ws As Worksheet, Found As Range
Dim myText As String, FirstAddress As String
Dim AddressStr As String, foundNum As Integer
myText = Range("D5")
If myText = "" Then Exit Sub
For Each ws In ThisWorkbook.Worksheets
With ws
'Do not search sheet1'
If ws.Name = "Sheet1" Then GoTo myNext
Set Found = .UsedRange.Find(What:=myText, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If Not Found Is Nothing Then
FirstAddress = Found.Address
Do
foundNum = foundNum + 1
AddressStr = AddressStr & .Name & " " & Found.Address & vbCrLf
Set Found = .UsedRange.FindNext(Found)
'Found.EntireRow.Copy _
'Destination:=Worksheets("Sheet4").Range("A65536").End(xlUp).Offset(1, 0)
Loop While Not Found Is Nothing And Found.Address <> FirstAddress
End If
myNext:
End With
Next ws
If Len(AddressStr) Then
Sheet8.Range("B18") = ws.Cells(x, 1)
Sheet8.Range("C18") = ws.Cells(x, 2)
Sheet8.Range("D18") = ws.Cells(x, 3)
Sheet8.Range("E18") = ws.Cells(x, 4)
Sheet8.Range("F18") = ws.Cells(x, 5)
Sheet8.Range("G18") = ws.Cells(x, 6)
Sheet8.Range("H18") = ws.Cells(x, 7)
Sheet8.Range("I18") = ws.Cells(x, 8)
Sheet8.Range("J18") = ws.Cells(x, 9)
Else:
MsgBox "Unable to find " & myText & " in this workbook.", vbExclamation
End If
End Sub
This is the original code for the last loop...
If Len(AddressStr) Then
MsgBox "Found: """ & myText & """ " & foundNum & " times." & vbCr & _
AddressStr, vbOKOnly, myText & " found in these cells"
Else:
MsgBox "Unable to find " & myText & " in this workbook.", vbExclamation
End If
Here, try this out. I redid how I interpreted the first section. I'm not entirely sure what you're trying to do with everything so let me know if this works or where it went wrong.
Sub FindOne()
Dim k As Integer
Dim myText As String, searchColumn As String
Dim totalValues As Long
Dim nextCell As Range
k = ThisWorkbook.Worksheets.Count
myText = Sheets(1).Range("D5").Value
If myText = "" Then
MsgBox "No Address Found"
Exit Sub
End If
Select Case ComboBox1.Value
Case "Equipment Number"
searchColumn = "A"
Case "Sequence Number"
searchColumn = "B"
Case "Repair Order Number(s)"
searchColumn = "D"
Else
MsgBox "Please select a value for what you are searching by."
End Sub
End Select
For i = 2 To k
totalValues = Sheets(i).Range("A65536").End(xlUp).Row
ReDim AddressArray(totalValues) As String
For j = 0 To totalValues
AddressArray(j) = Sheets(i).Range(searchColumn & j + 1).Value
Next j
For j = 0 To totalValues
If (InStr(1, AddressArray(j), myText) > 0) Then
Set nextCell = Sheets(1).Range("A65536").End(xlUp).Offset(1, 0)
Range(nextCell, nextCell.Offset(0, 8)).Value = Sheets(i).Range("A" & j, "I" & j).Value
End If
Next j
Next i
End Sub
Also I have no clue what that second part of the code is supposed to be, so if you want to elaborate on the section with If Len(AddressStr) Then, I'd appreciate it because that really doesn't even work as an If...Then statement lol :)
So, I have the code below in my "Thisworkbook" Module. I need it to run whenever the user saves the workbook. The code opens another workbook and transfers data into the new workbook.
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Exit Sub
On Error Resume Next
Dim Mas_loc As String
Mas_loc = "C:\Users\J03800\Documents\All Folders\Berry\MasterBerry.xlsx"
Dim n As Integer
Dim m As Integer
Dim x As Integer
Dim y As Integer
Dim PartNumber As String
Dim CageCode As String
Dim PartCage As String
Dim MI As Integer
Dim ChildWB As Workbook
Dim MasterWB As Workbook
Dim IsMatch As Boolean
Dim ChiMain As Worksheet
Dim MasMain As Worksheet
Set ChildWB = ActiveWorkbook
Set MasterWB = Workbooks.Open(Mas_loc)
Set ChiMain = ChildWB.Sheets("Main")
Set MasMain = MasterWB.Sheets("Main")
n = Application.CountA(ChiMain.Range("B:B")) + 1
m = Application.CountA(MasMain.Range("B:B")) + 1
ChildWB.Activate
For x = 3 To n
PartNumber = ChiMain.Cells(x, "B").Value
CageCode = ChiMain.Cells(x, "A").Value
CSMC = ChiMain.Cells(x, "J").Value
CMC = ChiMain.Cells(x, "L").Value
MassObj = ChiMain.Cells(x, "E").Value
ComObj = ChiMain.Cells(x, "H").Value
If Len(PartNumber) > 0 Then
If Len(CageCode) > 1 Then
PartNumber = "-" & Replace(Replace(PartNumber, CageCode & "-", ""), "-" & CageCode, "")
PartCage = "Cage-" & CageCode & "-" & PartNumber
Else
PartCage = "NoCage-" & PartNumber
End If
Else
PartCage = ""
End If
On Error GoTo NewPart
MatchAddress = Application.WorksheetFunction.Match(PartCage, MasMain.Range("K1:K" & m + 20), 0)
contin:
On Error Resume Next
If Len(CSMC) > 0 And Len(Replace(CSMC, "?", "")) = Len(CSMC) And Len(MasMain.Cells(MatchAddress, "E").Value) = 0 Then
MasMain.Cells(MatchAddress, "E").Value = CSMC
End If
If Len(CMC) > 0 And Len(Replace(CMC, "?", "")) = Len(CMC) And Len(MasMain.Cells(MatchAddress, "H").Value) = 0 Then
MasMain.Cells(MatchAddress, "H").Value = CMC
End If
If Len(MassObj) > 0 And Len(Replace(MassObj, "?", "")) = Len(MassObj) And Len(MasMain.Cells(MatchAddress, "C").Value) = 0 Then
MasMain.Cells(MatchAddress, "C").Value = MassObj
End If
If Len(MassObj) > 0 And Len(Replace(MasMain.Cells(MatchAddress, "C").Value, ComObj, "")) = MasMain.Cells(MatchAddress, "C").Value Then
MasMain.Cells(MatchAddress, "G").Value = MasMain.Cells(MatchAddress, "G").Value & Chr(10) & ComObj
End If
Next
MasterWB.Close SaveChanges:=True
Exit Sub
NewPart:
On Error Resume Next
m = m + 1
MatchAddress = m
MasMain.Cells(MatchAddress, "A").Value = ChiMain.Cells(MatchAddress, "A").Value
MasMain.Cells(MatchAddress, "B").Value = ChiMain.Cells(MatchAddress, "B").Value
MasMain.Cells(MatchAddress, "K").Value = PartCage
GoTo contin
End Sub
The problem seems to be that is is not opening MasterWB. As, when it bugs out, MasterWB is both not open and according to the code equal to nothing. What should I change?
Your code block looks fine - assuming the path specified in Mas_loc is accurate.
What errors are you getting when it "bugs out"?
Have you stepped through the code to see what is happening?
I would comment out the On Error Resume Next statement to stop masking any runtime errors.
I made the sub not private, then it worked
I am new to Excel VBA and I really need your help. I have a code that will look for the duplicate values in Column A. This code will highlight the duplicate values. I want:
1.) This code to ONLY run when I click on a button.
2.) I would like to have (somewhere in the same worksheet), the number of duplicate results and a hyper link that when you click on it will direct you the duplicate result (this is because I have sometimes huge files that I need to validate). Here is the code I currently have:
Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim C As Range, i As Long
If Not Intersect(Target, Me.[A:A]) Is Nothing Then
Application.EnableEvents = False
For Each C In Target
If C.Column = 1 And C.Value > "" Then
If WorksheetFunction.CountIf(Me.[A:A], C.Value) > 1 Then
i = C.Interior.ColorIndex
f = C.Font.ColorIndex
C.Interior.ColorIndex = 3 ' Red
C.Font.ColorIndex = 6 ' Yellow
C.Select
MsgBox "Duplicate Entry !", vbCritical, "Error"
C.Interior.ColorIndex = i
C.Font.ColorIndex = f
End If
End If
Next
Application.EnableEvents = True
End If
End Sub
I would really appreciate it if you help me with this.
Add the code to Module1 Alt+F11
Option Explicit
Sub MyButton()
Dim RangeCell As Range, _
MyData As Range
Dim MyDupList As String
Dim intMyCounter As Integer
Dim MyUniqueList As Object
Dim lngLastRow As Long, lngLoopRow As Long
Dim lngWriteRow As Long
Set MyData = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Set MyUniqueList = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
MyDupList = "": intMyCounter = 0
'// Find Duplicate
For Each RangeCell In MyData
If RangeCell <> "V" And RangeCell <> "R" Then
If Evaluate("COUNTIF(" & MyData.Address & "," & RangeCell.Address & ")") > 1 Then
'// Color. Change to suit RGB(141, 180, 226).
RangeCell.Interior.Color = RGB(141, 255, 226)
If MyUniqueList.exists(CStr(RangeCell)) = False Then
intMyCounter = intMyCounter + 1
MyUniqueList.Add CStr(RangeCell), intMyCounter
If MyDupList = "" Then
MyDupList = RangeCell
Else
MyDupList = MyDupList & vbNewLine & RangeCell
End If
End If
Else
RangeCell.Interior.ColorIndex = xlNone
End If
End If
Next RangeCell
'// Move duplicate from Column 1 to Column 7 = (G:G)
lngWriteRow = 1
lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row
For lngLoopRow = lngLastRow To 1 Step -1
With Cells(lngLoopRow, 1)
If WorksheetFunction.CountIf(Range("A1:A" & lngLastRow), .Value) > 1 Then
If Range("G:G").Find(.Value, lookat:=xlWhole) Is Nothing Then
Cells(lngWriteRow, 7) = .Value
lngWriteRow = lngWriteRow + 1
End If
End If
End With
Next lngLoopRow
Set MyData = Nothing: Set MyUniqueList = Nothing
Application.ScreenUpdating = False
If MyDupList <> "" Then
MsgBox "Duplicate entries have been found:" & vbNewLine & MyDupList
Else
MsgBox "There were no duplicates found in " & MyData.Address
End If
End Sub
.
Add Module
Add Button
Assign to Macro
Im using the below code for seacrhing a set of keywords in a cell which has title. While running the code im getting "Run Time error 13" Type mismatch on b = cell.Value line.
Application.ScreenUpdating = False
Dim col As Range, cell1 As Range, a As String, b As String, i As Integer
Set col = Range("KW[KW1]")
Dim target, cell As Range
Sheets("Data").Select
Set target = Range(Range("B1"), Range("B65536").End(xlUp))
Dim term, tag As String
For Each cell1 In col
a = cell1.Value
term = a
tag = a
For Each cell In target
b = cell.Value
' If InStr(1, " " & cell & " ", " " & term & " ", 1) Then
If Module1.ExactWordInString(b, a) Then
For i = 1 To 15
If cell.Offset(0, i).Value = "" Then
cell.Offset(0, i).Value = tag
Exit For
End If
Next i
End If
Next cell
Next cell1
Application.ScreenUpdating = True
However its running perfectly if we have 1000 tiltes in a column, but i want to run this code for a massive range upto 50,000 to 200,000. Please help me.
Try this, you didn't declare target as a range, might be it.
BTW, when you compare string VBA is case sensitive, so try to use Lcase() if you only want to compare content!
Application.ScreenUpdating = False
Dim target As Range, cell As Range
Dim term As String, tag As String
Dim col As Range, cell1 As Range, a As String, b As String, i As Integer
Sheets("Data").Select
Set col = Range("KW[KW1]")
Set target = Range(Range("B1"), Range("B65536").End(xlUp))
For Each cell1 In col
a = Cstr(cell1.Value)
term = a
tag = a
For Each cell In target
b = Cstr(cell.Value)
'If InStr(1, " " & cell & " ", " " & term & " ", 1) Then
If Module1.ExactWordInString(b, a) Then
For i = 1 To 15
If cell.Offset(0, i).Value = "" Then
cell.Offset(0, i).Value = tag
Exit For
End If
Next i
End If
Next cell
Next cell1
Application.ScreenUpdating = True