I've created a form to reformat a report that I receive and I'm having an issue with automating part of it. Everything works until I define and set the last variable codelength which I want to set as the length of a cell (first column, second row) in a defined range. I receive run time error 424, "Object Required". I appreciate any help!!
Here is the code:
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim rg As Range
Dim rgg As Range
Dim Addr1 As String
Dim Addr2 As String
'Get the address, or reference, from the RefEdit control.
Addr1 = RefEdit1.Value
Addr2 = RefEdit2.Value
'Set the SelRange Range object to the range specified in the
'RefEdit control.
Set rg = Range(Addr1)
Set rgg = Range(Addr2)
ActiveWorkbook.Names.Add Name:="codes", RefersTo:=rgg
'Infill
'Copies the value from the row above into blank cells.
Dim cel As Range, col As Range
Set rg = Range(Addr1).Columns(1).Resize(, 2)
On Error Resume Next
For Each col In rg.Columns
Set rgg = Nothing
Set rgg = col.SpecialCells(xlCellTypeBlanks)
If Not rgg Is Nothing Then
rgg.FormulaR1C1 = "=R[-1]C" 'Blank cells set equal to value from row above
rgg.Formula = rgg.Value 'Optional: Replace the formulas with the values returned by the formulas
End If
Next
Set rgg = rg.Offset(1, 0).Resize(rg.Rows.Count - 1, rg.Columns.Count)
For Each cel In rgg.Cells
If cel = "" Then cel.Value = cel.Offset(-1, 0).Value
Next
On Error GoTo 0
'ColCDeleter
Dim i As Long, n As Long
Set rg = Intersect(ActiveSheet.UsedRange, Range(Addr1).Columns(3))
n = rg.Rows.Count
For i = n To 1 Step -1
If rg.Cells(i, 1) = "" Then rg.Cells(i, 1).EntireRow.Delete
Next
'insert corresponding values
Dim codelength As Integer
codelength = Len(codes.Cells(2, 1).Value)
rg.Columns(2).EntireColumn.Insert
rg.Columns(2).EntireColumn.Insert
rg.Columns(2).EntireColumn.Insert
rg.Columns(2).EntireColumn.Insert
If codelength = 6 Then
rg.Columns(2).FormulaR1C1 = "=VLOOKUP((MID(RC1,9,9)),codes,2,FALSE)"
rg.Columns(3).FormulaR1C1 = "=VLOOKUP((MID(RC1,9,9)),codes,3,FALSE)"
Else
rg.Columns(2).FormulaR1C1 = "=VLOOKUP((MID(RC1,8,9)),codes,2,FALSE)"
rg.Columns(3).FormulaR1C1 = "=VLOOKUP((MID(RC1,8,9)),codes,3,FALSE)"
End If
rg.Cells(1, 2).Value = "Plan"
rg.Cells(1, 3).Value = "Status"
'Unload the userform.
Unload Me
End Sub
When you first name a range using the following syntax
Dim rng as Range
Set rng = Range("A1:A10")
ActiveWorkbook.Names.Add Name:="codes", RefersTo:=rng
Then this becomes just a name - it's not a stand alone object. So the error you are getting tells you exactly what is happening -> Object required.
To refer to the named Range you wrap it in double quotes and stick it as the parameter for the Range object. Therefore, Range("codes") creates a Range object referring to the rng Range.
An alternative, omitting the name would be to use the rng Range object simply replacing the Range("codes"). with rng.
Related
I have growing data files and in a certain column is not fill out. I have the code to fill the data, though I want to make a button to call userform for user to fill in the range so that the code works within the range provided by the user(since data is adjusted by the user itself). The code to fill the blank cell is;
Sub fillblank()
Dim range As Range
Dim cell As Range
Dim value As String
Set range = Sheets("Sheet1").Range("E4:E15")
For Each cell In range
If Trim(cell.Value) <> "" Then
value = cell.Value
Else
cell.Value = value
End if
Next cell
End Sub
I would like the user to enter the range (E4:E15) in userform. How to do the userform if its dependent only range? Thanks stackoverflow.com.
Put a text box in userform and name it txtRng. Then declare a variable named MyRng as String. Assign that text box value to MyRng variable and use this variable as argument of range like...
Set range = Sheets("Sheet1").Range(MyRng)
So, full code will be like as below
Sub fillblank()
Dim range As range
Dim cell As range
Dim value As String
Dim MyRng As String
MyRng = UserForm1.txtRng 'Use your form name here
Set range = Sheets("Sheet1").range(MyRng)
For Each cell In range
If Trim(cell.value) <> "" Then
value = cell.value
Else
cell.value = value
End If
Next cell
End Sub
I also suggest you to not use range, value as variable because some of these reserve keyword. It may cause misbehave of output.
You could use the InputBox() method and have the user select a range:
Sub fillblank()
Dim myRange As Range
Dim cell As Range
Dim myValue As String
Set myRange = Application.InputBox( prompt:="Select a range", Type:=8)
For Each cell In myRange
If Trim(cell.Value) <> "" Then
myValue = cell.Value
Else
cell.Value = myValue
End if
Next
End Sub
or you could add a RefEdit control to your userform and process it
Sub fillblank()
Dim cell As range
Dim myValue As String
For Each cell In range(Me.RefEdit1.Text)
If Trim(cell.value) <> "" Then
myValue = cell.value
Else
cell.value = myValue
End If
Next cell
End Sub
In this case, since the user could input an invalid range, you may want to add a validation function (named GetRange in my following example)
Sub fillblank()
Dim myRange As range
If Not GetRange(Me.RefEdit1.Text, myRange) Then
MsgBox "Select a valid range "
Me.RefEdit1.SetFocus
Exit Sub
End If
Dim cell As range
Dim myValue As String
For Each cell In myRange
If Trim(cell.value) <> "" Then
myValue = cell.value
Else
cell.value = myValue
End If
Next cell
End Sub
Function GetRange(RefEditText As String, myRange As range) As Boolean
On Error Resume Next
Set myRange = range(RefEditText)
On Error GoTo 0
GetRange = Not myRange Is Nothing
End Function
finally, here is an alternative method (no loops) to fill blank cells as you're wanting to do:
Sub fillblank()
With range(Me.RefEdit1.Text).SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[-1]C"
.value = .value
End With
End Sub
To ask the user for a range you could use InputBox(Type:=8)
The code bellow will accept only one column
If an entire column is selected (A:A) or multiple columns it adjusts to the total rows in UsedRange and first column in selection
Option Explicit
Public Sub FillBlanks()
Dim selectedCol As Range, itm As Range, lr As Long
On Error Resume Next
Set selectedCol = Application.InputBox(Prompt:="Select column:", Type:=8)
On Error GoTo 0
If selectedCol Is Nothing Then Exit Sub 'User cancelled selection
With selectedCol
.Parent.Activate
lr = .Parent.UsedRange.Rows.Count
If .Columns.Count > 1 Then Set selectedCol = .Resize(.Rows.Count, 1)
If .Rows.Count < 2 Or .Rows.Count > lr Then Set selectedCol = .Resize(lr - .Row + 1, 1)
selectedCol.Select
End With
For Each itm In selectedCol
If Len(Trim$(itm)) = 0 And itm.Row > 1 Then itm.Value2 = itm.Offset(-1).Value2
Next
End Sub
Note: It's not recommended to name your variables with special VBA keywords
Dim range As Range - Range is the most important object in Excel
Dim value As String - Value is the most important property of the Range object
My overall goal here is to grab the values and row indices of three different columns on the original spreadsheet, evaluate them, and then save them to a new spreadsheet. I am wanted to accomplish this by using a macro initiated by a button on the original spreadsheet.
The plan to accomplish this was to
create a Range for each column
Loop through the most significant Range to grab and evaluate the each cell value
perform nested loops within the first loop to further evaluate the other two Ranges and grab their values
assign values to variables
create the new spreadsheet from a template
write the values to the respective columns
save the new spreadsheet
When I run the code below I get the error listed below. I'm confused because I thought this is how you reference an entire column:
Sub Transfer2NewWorkbook()
Dim currentsheet As String
Dim newsheet As String
Dim analysisDate As String
Dim initial As String
Dim aInitial() As String
Dim analystInit As String
Dim batchNo As String
Dim wb As Object
Dim dataRangeA As Range, dataRangeB As Range, dataRangeI As Range
Set dataA = CreateObject("Scripting.Dictionary")
' Grab and Create filenames
currentsheet = ActiveWorkbook.Name
newsheet = currentsheet & "-" & "uploadable"
' Grab data from original spreadsheet
analysisDate = ActiveWorkbook.Sheets(1).Cells(1, 9).Value
initial = ActiveWorkbook.Sheets(1).Cells(1, 2).Value
aInitial = Split(initial, "/")
analystInit = aInitial(1)
Set dataRangeA = Range("A4:A").Select ' <-- Line causing error
Set dataRangeB = Range("B4:B").Select
Set dataRangeI = Range("I4:I").Select
For i = 1 To dataRangeA.Rows.Count
dataA.Add Key:=i, Item:=dataRangeA.Cells.Value
Next i
Set wb = Workbooks.Add("C:\Users\dalythe\documents\uploadtemp.xlsx")
ActiveWorkbook.Sheets(1).Cells(3, 2).Value = analysisDate
ActiveWorkbook.Sheets(1).Cells(3, 4).Value = analystInit
ActiveWorkbook.SaveAs (newsheet & ".xlsx")
End Sub
try this:
Set dataRangeA = Range("A:A").Select
Set dataRangeB = Range("B:B").Select
Set dataRangeI = Range("I:I").Select
For i = 4 To dataRangeA.Rows.Count
dataA.Add Key:=i, Item:=dataRangeA.Cells.Value
Next i
After removing the .Select, my ranges were accepted.
Set dataRangeA = Range("A:A")
Set dataRangeB = Range("B:B")
Set dataRangeI = Range("I:I")
For i = 4 To dataRangeA.Rows.Count
dataA.Add Key:=i, Item:=dataRangeA.Cells.Value
Next i
Thanks for the input YowE3k. Now I have to think on how I want my loop to end. Because doing it the way I have it above will cause it to run out of memory. The spreadsheet will not have a "predefined" number of rows. I guess I will have to have the user type "End" in the cell of the last row or something.
Your problems with the particular line throwing the error are caused by two things:
"A4:A" is not a valid address in Excel. You can either use "A:A" for the entire column or define the end of the range, e.g. "A4:A272".
The Range.Select method does not return an object, so Set dataRangeA = Range("A4:A").Select is effectively Set dataRangeA =.
To fix your specific error, you could do something like:
Set dataRangeA = Range("A4", Cells(Rows.Count, "A").End(xlUp))
However, using unqualified Cells and Range and Rows is a dangerous habit to get into once you have more than one worksheet / workbook being used in your code, because those objects default to referring to the ActiveSheet in the ActiveWorkbook and that may not be the one you are expecting it to be.
The code below ensures that each object is qualified, plus makes some other improvements to your code (such as the inevitable out-of-memory error that would arise in populating the Dictionary).
Sub Transfer2NewWorkbook()
Dim currentsheet As String
Dim newsheet As String
Dim analysisDate As String
Dim initial As String
Dim aInitial() As String
Dim analystInit As String
Dim batchNo As String
Dim wb As Object
Dim dataRangeA As Range, dataRangeB As Range, dataRangeI As Range
Dim dataA As Object ' declare this, unless you have declared it at a higher
' level scope
Set dataA = CreateObject("Scripting.Dictionary")
' Grab and Create filenames
currentsheet = ActiveWorkbook.Name
newsheet = currentsheet & "-" & "uploadable"
'Use a With block to avoid having to constantly refer
' to "ActiveWorkbook.Sheets(1)"
With ActiveWorkbook.Sheets(1)
' Grab data from original spreadsheet
analysisDate = .Cells(1, 9).Value
initial = .Cells(1, 2).Value
aInitial = Split(initial, "/")
analystInit = aInitial(1)
Set dataRangeA = .Range("A4", .Cells(.Rows.Count, "A").End(xlUp))
Set dataRangeB = .Range("B4", .Cells(.Rows.Count, "B").End(xlUp))
Set dataRangeI = .Range("I4", .Cells(.Rows.Count, "I").End(xlUp))
'This loop is making every entry in the Dictionary contain the value of
'every cell in the range - i.e. each of the 1048573 entries in the Dictionary
'would have contained an array which was dimensioned As (1 To 1048573, 1 To 1)
'For i = 1 To dataRangeA.Rows.Count
' dataA.Add Key:=i, Item:=dataRangeA.Cells.Value
'Next i
Dim cel As Range
For Each cel in dataRangeA
dataA.Add Key:=cel.Row, Item:=cel.Value
'or
'dataA.Add Key:=cel.Row - 3, Item:=cel.Value
'if you wanted A4's value to have a key of 1
Next
'Note: If you just wanted an array of values, you could have used
' Dim dataA As Variant
' dataA = Application.Transpose(.Range("A4", .Cells(.Rows.Count, "A").End(xlUp)))
'and then access each value using dataA(1) for the value from A4,
'dataA(2) for the value from A5, etc.
'This then gets rid of the need for dataRangeA, and the need for a
' dictionary object, and the need for the loop populating the dictionary.
End With
Set wb = Workbooks.Add("C:\Users\dalythe\documents\uploadtemp.xlsx")
With wb.Worksheets(1)
.Cells(3, 2).Value = analysisDate
.Cells(3, 4).Value = analystInit
End With
wb.SaveAs newsheet & ".xlsx"
End Sub
I can't seem to figure out one condition of my code. I'm also a beginner at VBA. In short, I have a slicer on one worksheet that contains my filter values, and I have a range of 19 cells that can be updated with a drop down list I setup using data validation.
When a value is selected in ANY cell of the range on the source worksheet (source range is M8:M26), I need it to update the corresponding cell in a range of another workbook (which is not a continuous range like in the source workbook). For example, M8 will update AB335 when the filter is on desk1, M9 will update AB358, etc... I'm having the most trouble figuring out how to loop the update so if the first cell in the source range is blank, skip to the next and continue with the updates.
If the cell is blank, I also don't want it to override the destination range cell with a blank value, and so far that seems to work with my code. I just can't get it to update if the values are updated in a random order on the source range. Weird caveat is if I enter all of the values without skipping a cell, it will update fine. How can I figure out how to move to the next cell and continue with the update if the previous cell had no selection? Here's what I have for code so far:
Sub UpdateRisk_Click()
Dim wksSource As Worksheet, wksDest As Worksheet
Dim strArray(0 To 18) As String
Dim Arng As Range
Dim Brng As Range
Dim cell As Range
Dim counter As Long
Set wksSource = ActiveWorkbook.Sheets("By Risk Pivot")
Set wksDest = ActiveWorkbook.Sheets("(NEW) Full Data")
Set Arng = wksDest.Range("AB335,AB358,AB379,AB380,AB382,AB383,AB386,AB391,AB404,AB409,AB410,AB412,AB413,AB423,AB427,AB432,AB438,AB442,AB443,AB444")
Set Brng = wksDest.Range("AB109,AB130,AB151,AB152,AB155,AB157,AB159,AB166,AB178,AB185,AB186,AB187,AB188,AB193,AB197,AB199,AB204,AB206,AB208,AB209")
counter = 0
strArray(0) = wksSource.Range("M8")
strArray(1) = wksSource.Range("M9")
strArray(2) = wksSource.Range("M10")
strArray(3) = wksSource.Range("M11")
strArray(4) = wksSource.Range("M12")
strArray(5) = wksSource.Range("M13")
strArray(6) = wksSource.Range("M14")
strArray(7) = wksSource.Range("M15")
strArray(8) = wksSource.Range("M16")
strArray(9) = wksSource.Range("M17")
strArray(10) = wksSource.Range("M18")
strArray(11) = wksSource.Range("M19")
strArray(12) = wksSource.Range("M20")
strArray(13) = wksSource.Range("M21")
strArray(14) = wksSource.Range("M22")
strArray(15) = wksSource.Range("M23")
strArray(16) = wksSource.Range("M24")
strArray(17) = wksSource.Range("M25")
strArray(18) = wksSource.Range("M26")
For Each cell In Arng
If (strArray(counter) <> "") And (ActiveWorkbook.SlicerCaches("Slicer_Global_Desk1").SlicerItems("desk1").Selected = True) Then
cell.Value = strArray(counter)
counter = counter + 1
End If
Next cell
For Each cell In Brng
If Not (strArray(counter) = "") And (ActiveWorkbook.SlicerCaches("Slicer_Global_Desk1").SlicerItems("desk2").Selected = True) Then
cell.Value = strArray(counter)
counter = counter + 1
End If
Next cell
Call PivotTableRefresh
MsgBox "Updated Successfully"
End Sub
I refactored your code a little bit:
Sub UpdateRisk_Click()
Dim wksSource As Worksheet
Dim wksDest As Worksheet
Dim strArray(0 To 18) As String
Dim Arng As Range
Dim Brng As Range
Dim cell As Range
Dim i As Integer
Set wksSource = ActiveWorkbook.Sheets("By Risk Pivot")
Set wksDest = ActiveWorkbook.Sheets("(NEW) Full Data")
Set Arng = wksDest.Range("AB335,AB358,AB379,AB380,AB382,AB383,AB386,AB391,AB404,AB409,AB410,AB412,AB413,AB423,AB427,AB432,AB438,AB442,AB443,AB444")
Set Brng = wksDest.Range("AB109,AB130,AB151,AB152,AB155,AB157,AB159,AB166,AB178,AB185,AB186,AB187,AB188,AB193,AB197,AB199,AB204,AB206,AB208,AB209")
For i = 0 To 18
strArray(i) = wksSource.Range("M" & (i + 8))
Next i
If ActiveWorkbook.SlicerCaches("Slicer_Global_Desk1").SlicerItems("desk1").Selected Then
i = 0
For Each cell In Arng
If strArray(i) <> "" Then cell.Value = strArray(i)
i = i + 1
Next cell
End If
If ActiveWorkbook.SlicerCaches("Slicer_Global_Desk1").SlicerItems("desk2").Selected Then
i = 0
For Each cell In Brng
If strArray(i) <> "" Then cell.Value = strArray(i)
i = i + 1
Next cell
End If
Call PivotTableRefresh
MsgBox "Updated Successfully"
End Sub
A few notes:
double-check your wksDest assignment. It will work if the destination sheet is in the same workbook. If it's in a different book, your code won't work;
Your array contains 19 values, but your ranges have 20. They need to be in sync, otherwise you'll get a VBA error ("subscript out of range")
I have been struggling for a day and a half with my code. I have a spreadsheet with over 50 columns 18000 rows. I have been able to identify a smaller range of cells in column A defined by "AllEntRg" based on blank cells in column H(OpsCol). I'm stuck with my loops towards the bottom. For EntityRg, I am looping through each cell in "AllEntRg" and if it is Not found in Range CCRg which was defined in BudWb Wk4 Then I want to create a range of all of those cells. The next option, CostCRg, I want to define a range for all cells that ARE FOUND in CCrg.
I have tested this by selecting individual cells and it provides the results I'm looking for but when I have this in the loops I'm getting the following two results: For EntityRg, the range.address defined is the same as AllEntRg (this shouldn't be the case). For CostCRg, I'm getting an error. I'm not sure what I'm not defining correctly. I've been stuck here for quite a while and I have tried using Match Function as well. Again, individually it works but in the loop I'm getting these results which are not expected. I'm interested on the feedback I may receive. Thanks.
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim wb As Workbook
Dim BudWkb As Workbook
Dim Wk2 As Worksheet
Dim PNLWkb As Workbook
Dim fpath As String
Dim fname As String
Set BudWkb = Workbooks("SubModel Forecast_Other Admin v4.xlsm")
Set Wk2 = BudWkb.Sheets("By PM")
fname = "Feb15 PNL"
'fname = InputBox("Enter PNL File Name")
Dim Wk4 As Worksheet
Set Wk4 = BudWkb.Sheets("Validation")
With Wk4
Dim CCCol As Long
Dim fRowCC As Long
Dim lRowCC As Long
CCCol = Wk4.Cells.Find("Cost Center", lookat:=xlWhole).Column
fRowCC = Wk4.Cells.Find("Cost Center", lookat:=xlWhole).Offset(1, 0).row
lRowCC = Wk4.Cells.Find("Cost Center", lookat:=xlWhole).End(xlDown).row
Dim CCRg As Range
Set CCRg = Wk4.Range(Wk4.Cells(fRowCC, CCCol), Wk4.Cells(lRowCC, CCCol))
'MsgBox (CCRg.Address)
End With
Set PNLWkb = Workbooks("Feb15 PNL.xlsx")
Dim Wk1 As Worksheet
Set Wk1 = PNLWkb.Sheets("det")
With Wk1
If Left(Wk2.Name, 5) = "By PM" Then
Dim OpsCol As Long
OpsCol = Wk1.Cells.Find("Property Manager", lookat:=xlWhole).Column
Else
OpsCol = Wk1.Cells.Find("Submarket", lookat:=xlWhole).Column
End If
Dim FRow As Long
Dim lRow As Long
Dim ExpCol As Long
Dim PropCodeCol As Long
Dim Expense As String
Expense = InputBox("Enter Expense GL")
'to locate begining and ending row of data on PNL report
'Identifies the column where the SubMarket names are located for lookup purposes
'Defines the expense GL column to lookup based on the inputbox above
FRow = Wk1.Cells.Find("66990000", lookat:=xlPart).Offset(2, 0).row
lRow = Wk1.Cells.Find("66990000", lookat:=xlPart).End(xlDown).Offset(-1, 0).row
ExpCol = Wk1.Cells.Find(Expense, lookat:=xlPart).Column
PropCodeCol = Wk1.Cells.Find("Property Code", lookat:=xlWhole).Column
'Defines the Range of the PM or Sub-Market Names
Dim OpsRg As Range
Set OpsRg = Wk1.Range(Wk1.Cells(FRow, OpsCol), Wk1.Cells(lRow, OpsCol))
'Defines the Range of the Property Codes
Dim PropCodeRg As Range
Set PropCodeRg = Wk1.Range(Wk1.Cells(FRow, PropCodeCol), Wk1.Cells(lRow, PropCodeCol))
'Defines the exact range of the expense column being analyzed
Dim ExpRg As Range
Set ExpRg = Wk1.Range(Wk1.Cells(FRow, ExpCol), Wk1.Cells(lRow, ExpCol))
End With
Dim AllEntRg As Range
For Each Cell In OpsRg
If Cell = "" Then
If AllEntRg Is Nothing Then
Set AllEntRg = Cells(Cell.row, PropCodeCol)
Else
Set AllEntRg = Union(AllEntRg, Cells(Cell.row, PropCodeCol))
End If
'End If
End If
Next
MsgBox (AllEntRg.Address)
'MsgBox (Application.Match(Wk1.Cells(59, 1), CCRg, 0))
'Dim y
'y = Application.Match(Wk1.Cells(10, 1), CCRg, 0)
'If IsError(y) Then
'MsgBox ("pooopy error")
'End If
Dim EntityRg As Range
'Dim c As Range
For Each c In AllEntRg
'Dim z
'z = Application.Match(c, CCRg, 0)
If CCRg.Find(c.Value, lookat:=xlPart) Is Nothing Then
If EntityRg Is Nothing Then
Set EntityRg = c
Else
Set EntityRg = Union(EntityRg, c)
End If
End If
Next
MsgBox (EntityRg.Address)
Dim CostCRg As Range
Dim r As Range
For Each r In AllEntRg
If Not CCRg.Find(r.Value, lookat:=xlPart) Is Nothing Then
If CostCRg Is Nothing Then
Set CostCRg = r
Else
Set CostCRg = Union(CostCRg, r)
End If
End If
Next
MsgBox (CostCRg.Address)
Dim v As Double
v = Application.WorksheetFunction.Sum(EntityRg)
'SendKeys "{F9}"
MsgBox (v)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
I have no means of running your code but I have reviewed it and have noticed some possible problems.
lRowCC = Wk4.Cells.Find("Cost Center", lookat:=xlWhole).End(xlDown).row
`.End(xlDown) is not a reliable method of finding the last row of a column. Read this answer of mine for an explanation: Excel vba – xlDown
You say: “For EntityRg, the range.address defined is the same as AllEntRg (this shouldn't be the case).”
Do you believe they are the same because EntityRg.Address = AllEntRg.Address?
EntityRg .Address will be a string of absolute cell and range addresses separated by commas. You may not be aware that this string has a maximum length of about 255. I cannot find any documentation but from my own experimentation, EntityRg .Address will be truncated to less than 256 such that there is no partial cell or range address.
Are you being fooled by the first 255 characters of these addresses matching?
Another possibility is that every use of CCRg.Find(c.Value, lookat:=xlPart) returns Nothing so EntityRgand AllEntRg are equal. You say CostCRg gives an error; is this because it is Nothing?
You have two loops searching CCRg for values in AllEntRg. One loop records the successes and one records the failures. Why not combine the loops into something like:
If CCRg.Find(c.Value, lookat:=xlPart) Is Nothing Then
If EntityRg Is Nothing Then
Set EntityRg = c
Else
Set EntityRg = Union(EntityRg, c)
End If
Else
If CostCRg Is Nothing Then
Set CostCRg = r
Else
Set CostCRg = Union(CostCRg, r)
End If
End If
I am concerned that For Each c In AllEntRg is not giving you what you expect. If you combine ranges with Union, it will tidy them up. So Union(Range("A2"), Range("A3", Range("A5"), Range("A6"), Range("A7")).Address is
"$A$2:$A$3,$A$5:$A$7" not "$A$2,$A$3,$A$5,$A$6,$A$7". My recollection is that For Each c In AllEntRg would not split "$A$2:$A$3" into separate cells.
Please use F8 to step through this loop to check that it is performing as you expect.
Hope this helps
Answer to problem described in comment
Your problem is you are not being consistent in you use of Withs and, in particular, you are not identifying which workbook you want to operate on.
Wk4 is explicitly specified to be within workbook BufdWkb and Wk1 is specified to be within PNLWkb.
However, in
Set AllEntRg = Cells(Cell.row, PropCodeCol)
you do not specify a worksheet or workbook for Cells. This is the equivalent of
Set AllEntRg = ActiveWorkbook.ActiveSheet.Cells(Cell.row, PropCodeCol)`
You need to write Set AllEntRg = .Cells(Cell.row, PropCodeCol) (note period before Cells) and include this code within the With Wk1 Block.
I have a function that selects a range based on a whole bunch of criteria from Sheet2. I'm trying to copy this range and to show/paste on Sheet1 or have it show in a message box.
Public Function findrulepos(target As Range, destination As Range) As String
Dim ruleStart As Range
Dim ruleEnd, ruleEnd2 As String
Dim Xcell, PasteRangeIndexCell As Range
Dim RuleRange As Range
Dim LastCell As Range
Dim FirstCell, IndexCell As Range
Dim WholeRule As Range
MaxRule = 100000
MaxRow = 100000
Sheets("ResRules").Select
For i = 2 To MaxRow
If CStr(ThisWorkbook.Sheets("ResRules").Range("A" & i).Value) = CStr(target.Value) Then
Set ruleStart = ThisWorkbook.Sheets("ResRules").Range("B" & i) '.offset(0, 1)
Exit For
End If
Next i
'MsgBox (ruleStart.address)
Set FirstCell = ruleStart.offset(1, -1)
Set IndexCell = FirstCell
Do Until IndexCell.Value <> "" Or IndexCell.Row >= MaxRow
Set IndexCell = IndexCell.offset(1, 0)
Loop
If IndexCell.Value <> "" Then
Set LastCell = IndexCell.offset(-1, 1)
MsgBox (LastCell.Value)
Else
Set LastCell = Nothing
End If
Set WholeRule = ThisWorkbook.Sheets("ResRules").Range("" & ruleStart.address & ":" & LastCell.address & "")
End Function
This is the whole code to give me the range I require
I have added a watch and can see I am getting the correct range i.e. $B$3:$B$6 but cant copy this range to Sheet 1
If your function is being called from a worksheet cell, then copy/paste won't work since that type of function can only return a value to the cell in which it resides. You need a function called from a Sub.
Use the following to get the address:
Sheet1.Range("A1").value = WholeRule.address
or, if you want to copy the actual content in the cells:
WholeRule.copy Sheet1.Range("A1")
thanks guys
worked it out
changed it to a Sub then
Public Sub ReturnRuleButton()
Call findrulepos(ThisWorkbook.Sheets("Main").Cells(2, 5), ThisWorkbook.Sheets("Main").Cells(2, 6))
End Sub