I came across this code that was provided on a prior question on this topic. It is the exact issue I am trying to solve.
I pasted the code, changed the column range to "A", as my values are in Columns A & B. Column A is my "Category" or criteria and I want Column B to be the values displayed in the named range.
Here is my column data:
When I run the code, I am getting an error:
1004: Method 'Range' of object'_Worksheet'Failed
It Debugs at:
Set rng = sht.Range(cell.Offset(0,1))
Here is the code I am using:
Dim featuresRng As Range
Dim rng As Range
Dim sht As Worksheet
Dim counter As Long
Dim cell As Range
Set sht = ThisWorkbook.Worksheets("Category Details")
Set featuresRng = sht.Range(sht.Range("A1"), sht.Range("A" & sht.Rows.Count).End(xlUp)) 'dynamically set the range of features
counter = 0 'this counter will help us avoid Union(Nothing, some range), which would give an error
For Each cell In featuresRng 'loop through the range of features
If cell.Value = "Essential Oils" Then
counter = counter + 1
If counter = 1 Then
Set rng = sht.Range(cell.Offset(0, 1))
Else
Set rng = Union(rng, sht.Range(cell.Offset(0, 1))) 'build the range
End If
End If
Next cell
Debug.Print rng.Address
sht.Names.Add "Something", rng
End Sub`
Related
I'm trying to create a function that inserts a filter within a cell range if a cell contains a value
Sub FilterFunc()
Dim i As Long, lastCol As Long
Dim rng As Range, cell As Range
Dim wSheet As Worksheet
Set wSheet = Worksheets("Sheet1")
'find the last column in row one
lastCol = wSheet.Cells(1, Columns.Count).End(xlToRight).Column 'xlToLeft
'set range from A1 to last column
Set rng = wSheet.Range(Cells(1, 1), Cells(1, lastCol))
'Outline the autofilter field hierarchy
i = 1
For Each cell In rng
If cell.Value <> "" Then
wSheet.Cells(cell.Row + 2, cell.Column).AutoFilter Field:=cell.Column, Criteria1:=cell.Value
End If
Next cell
End Sub
At the moment when the following code is executed:
wSheet.Cells(cell.Row + 2, cell.Column).AutoFilter
Field:=cell.Column, Criteria1:=cell.Value
It returns Runtime error: 1004 Autofilter Method of Range class failed
Its probably something silly but im trying to figure out where im going wrong
I have a manual selection process that I have tried but failed to automate, so I am reaching out for help. I have attached an image of my Excel sheet as a visual guide when reading my process. Excel Snapshot.
I select cell "L2" and run the code below. It finds the first instance of the value within "A2:J1501" and cuts the whole row. It pastes the row onto the sheet named Lineups. Then it highlights each of the values of the cut row in column "L:L" to let me know that value has been used. I then manually select the next non-highlighted value (in the image example it would be "L2") and run the code again, and again, and again, until every row of L:L is highlighted. This process can take some time depending on the number of rows in L:L so I was hoping I can get some help to automate.
Thank you very much.
Sub ManualSelect()
Dim rng As Range
Set rng = Range("A1:J1501")
Dim ac As Range
Set ac = Application.ActiveCell
rng.Find(what:=ac).Select
Range("A" & ActiveCell.Row).Resize(1, 10).Cut
ActiveWindow.ScrollRow = 1
Sheets("Lineups").Select
nextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(nextRow, 1).Select
ActiveSheet.Paste
Sheets("Data").Select
Dim wsData As Worksheet
Dim wsLineups As Worksheet
Dim rngToSearch As Range
Dim rngLineupSet As Range
Dim rngPlayerID As Range
Dim Column As Long
Dim Row As Long
Dim LastRow As Long
Set wsData = Sheets("Data")
Set wsLineups = Sheets("Lineups")
Set rngPlayerID = wsData.Range("L2:K200")
Set rngToSearch = rngPlayerID
LastRow = wsLineups.Cells(Rows.Count, 1).End(xlUp).Row
For Row = 2 To LastRow
For Column = 1 To 10
Set rngLineupSet = rngPlayerID.Find(what:=wsLineups.Cells(Row, Column), LookIn:=xlValues)
If Not rngLineupSet Is Nothing Then rngLineupSet.Interior.Color = 65535
Next Column
Next Row
End Sub
This should be pretty close:
Sub ManualSelect()
Dim wsData As Worksheet, c As Range, dict As Object, v, rw As Range
Dim wsLineups As Worksheet, c2 As Range, f As Range
Set dict = CreateObject("scripting.dictionary") 'for tracking already-seen values
Set wsLineups = ThisWorkbook.Worksheets("Lineups")
Set wsData = ThisWorkbook.Worksheets("Data")
For Each c In wsData.Range("L2", wsData.Cells(Rows.Count, "L").End(xlUp))
v = c.Value
If dict.exists(CStr(v)) Then
c.Interior.Color = vbYellow 'already seen this value in L or a data row
Else
'search for the value in
Set f = wsData.Range("A2:J1501").Find(v, lookat:=xlWhole, LookIn:=xlValues, searchorder:=xlByRows)
If Not f Is Nothing Then
Set rw = f.EntireRow.Columns("A").Resize(1, 10) 'A to J
For Each c2 In rw.Cells 'add all values from this row to the dictionary
dict(CStr(c2)) = True
Next c2
rw.Cut Destination:=wsLineups.Cells(Rows.Count, "A").End(xlUp).Offset(1)
c.Interior.Color = vbYellow
Else
'will there always be a match?
c.Interior.Color = vbRed 'flag no matching row
End If
End If 'haven't already seen this col L value
Next c 'next Col L value
End Sub
I believe this should do it (updated):
Sub AutoSelect()
Dim wsData As Worksheet, wsLineups As Worksheet
Dim rng As Range, listIDs As Range
Set wsData = ActiveWorkbook.Sheets("Data")
Set wsLineups = ActiveWorkbook.Sheets("Lineups")
Set rng = wsData.Range("A2:J1501")
'get last row col L to define list
LastRowL = wsData.Range("L" & Rows.Count).End(xlUp).Row
Set listIDs = wsData.Range("L2:L" & LastRowL)
'loop through all cells in list
For i = 1 To listIDs.Rows.Count
myCell = listIDs.Cells(i)
'retrieve first mach in listID
checkFirst = Application.Match(myCell, listIDs, 0)
'only check first duplicate in list
If checkFirst = i Then
'get new row for target sheet as well (if sheet empty, starting at two)
newrow = wsLineups.Range("A" & Rows.Count).End(xlUp).Row + 1
'check if it is already processed
Set processedAlready = wsLineups.Cells(2, 1).Resize(newrow - 1, rng.Columns.Count).Find(What:=myCell, lookat:=xlWhole, LookIn:=xlValues)
'if so, color yellow, and skip
If Not processedAlready Is Nothing Then
listIDs.Cells(i).Interior.Color = vbYellow
Else
'get fist match for value, if any (n.b. "xlWhole" ensures whole match)
Set foundMatch = rng.Find(What:=myCell, lookat:=xlWhole, LookIn:=xlValues)
'checking for a match
If Not foundMatch Is Nothing Then
'get the row
foundRow = foundMatch.Row - rng.Cells(1).Row + 1
'specify target range and set it equal to vals from correct row in rng
wsLineups.Cells(newrow, 1).Resize(1, rng.Columns.Count).Value2 = rng.Rows(foundRow).Value
'clear contents rng row
rng.Rows(foundRow).ClearContents
'give a color to cells that actually got a match
listIDs.Cells(i).Interior.Color = vbYellow
Else
'no match
listIDs.Cells(i).Interior.Color = vbRed
End If
End If
Else
'duplicate already handled, give same color as first
listIDs.Cells(i).Interior.Color = listIDs.Cells(checkFirst).Interior.Color
End If
Next i
End Sub
Also, I think, slightly faster than the other solution offered (because of the nested loop there?). Update: I got a bit confused about the nested loop in the answer by Tim Williams, but I missed that you also want to "accept" the values in the list that matched on a row that is already gone. I fixed this in the updated version by checking if a value that fails to match on the data range has already been transferred to Lineups. Provided that doing so is permissible, this method avoids the nested loop.
I checked both methods for speed (n = 50) on a list (n = 200) for the full data range, ended up with average of 1.70x faster... But maybe speed is not such a big deal, if you're coming from manual labor :)
Hi guys i need some help on VBA.
I have range of numbers in sheet 1 from cells A6:O29. Next I have specific numbers selected in Sheet 3 in Column "B".
[![enter image description here][1]][1]
[![enter image description here][2]][2]
I want to loop throw each value in Sheet 3 Column B and find that specific value in Sheet 1 range A6:O29
Next it should paste Entire Row from Sheet 1 starting From Column (Q:CF) in Sheet 3 Starting from Column C onwards
I have coded it but its not working.
Private Sub CommandButton1_Click()
Dim main As Worksheet
Dim outcome As Worksheet
'main sheet contains Range to search number in
Set main = ThisWorkbook.Sheets("Sheet1")
'outcome sheet has specific values in Column B
Set outcome = ThisWorkbook.Sheets("Sheet3")
'column B values are considrered as doubles
Dim valuesfind As Double
'range where values are to be found
Dim myrange As Range
Set myrange = Worksheets("Sheet1").Range("A6:O29")
'no of times to loop code based on values in outcomesheet
locations = Worksheets("Sheet3").Cells(Rows.Count, 2).End(xlUp).Row
For i = 6 To locations
degrees = outcome.Range("B" & i).Value
For b = 6 To Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
If main.Range("A6:O29" & b).Value = degrees Then
outecome.Range("C:BR" & i).Value = main.Range("Q:CF" & b).Value
Exit For
End If
Next b
Next i
End Sub
[1]: https://i.stack.imgur.com/uBo66m.png
[2]: https://i.stack.imgur.com/D0bRUm.png
Please remember to declare all variables, add Option Explicit at the top of your module to help you enforce it.
Try the code below:
Option Explicit
Private Sub CommandButton1_Click()
'main sheet contains Range to search number in
Dim main As Worksheet
Set main = ThisWorkbook.Sheets("Sheet1")
Const mainCopyRng As String = "Q?:CF?"
'outcome sheet has specific values in Column B
Dim outcome As Worksheet
Set outcome = ThisWorkbook.Sheets("Sheet3")
Const outcomePasteRng As String = "C?:BR?"
'range where values are to be found
Dim myrange As Range
Set myrange = main.Range("A6:O29")
'no of times to loop code based on values in outcomesheet
Dim outcomeLastRow As Long
outcomeLastRow = outcome.Cells(Rows.Count, 2).End(xlUp).Row
Dim i As Long
For i = 6 To outcomeLastRow
Dim Degrees As Double
Degrees = outcome.Cells(i, 2).Value
Dim searchRng As Range
Set searchRng = myrange.Find(Degrees, LookIn:=xlValues, LookAt:=xlWhole)
If Not searchRng Is Nothing Then
Dim searchRow As Long
searchRow = searchRng.Row
outcome.Range(Replace(outcomePasteRng, "?", i)).Value = main.Range(Replace(mainCopyRng, "?", searchRow)).Value
End If
Next i
End Sub
This should work.
Sub Test()
Dim main As Worksheet
Set main = ThisWorkbook.Sheets("Sheet1")
Dim myrange As Range
Set myrange = main.Range("A6:O29")
Dim outcome As Worksheet
Set outcome = ThisWorkbook.Sheets("Sheet3")
'Set reference to locations in sheet3.
Dim locations As Range
With outcome
Set locations = .Range(.Cells(1, 2), .Cells(Rows.Count, 2).End(xlUp))
End With
'Search for each location in Sheet1 and if found copy to Sheet3.
Dim location As Range
Dim FoundLocation As Range
For Each location In locations
Set FoundLocation = myrange.Find( _
What:=location, _
After:=myrange.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext)
If Not FoundLocation Is Nothing Then
main.Cells(FoundLocation.Row, 1).Resize(, 15).Copy _
Destination:=location.Offset(, 1)
End If
Next location
End Sub
I have a data set with columns from A to AZ. I want to find if any cell value in Columns A & B is found in Columns AA:AZ and I want a list of those unique not found values from all the compared columns.
What I did first is create 2 new sheets to separate the comparison. 1st sheet (SKUReference) which is copied from column A & B. Second sheet is (SKUNewList) which is copied from AA till AZ. I created a 3rd sheet (NotFoundSKU) to have the desired output which is the Not Found values from the comparison.
The data in the 1st sheet (SKUReference) looks like below :
The data in the 2nd sheet (SKUNewList) looks like below :
The issue I'm facing is : 1- the code isn't finding the Mismatches. 2- It's not storing the unique mismatches correctly. 3- It's not generating those mismatches in the 3rd sheet (NotFoundSKU).
Sub yg23iwyg()
Dim wst As Worksheet
Dim wet As Worksheet
Set wst = Worksheets.Add
Set wet = Worksheets.Add
Set wrt = Worksheets.Add
wst.Name = "SKUReference"
wet.Name = "SKUNewList"
wrt.Name = "NotFoundSKU"
With Worksheets("Sheet1")
.Range(.Cells(1, "A"), .Cells(.Rows.Count, "B").End(xlUp)).Copy _
Destination:=wst.Cells(1, "A")
.Range(.Cells(1, "AA"), .Cells(.Rows.Count, "AZ").End(xlUp)).Copy _
Destination:=wet.Cells(1, "A")
'alternate with Union'ed range - becomes a Copy, Paste Special, Values and Formats because of the union
.Range("AA:AZ").Copy _
Destination:=wet.Cells(1, "A")
End With
Dim wksMaster As Worksheet, wksSearch As Worksheet
Dim rngMaster As Range, rngSearch As Range
Set wksMaster = Sheets("SKUReference")
Set wksSearch = Sheets("SKUNewList")
With wksMaster
Set rngMaster = .Range("A1:B100" & .Range("A1").SpecialCells(xlCellTypeLastCell).Row)
End With
With wksSearch
Set rngSearch = .Range("A1:Y100" & .Range("A1").SpecialCells(xlCellTypeLastCell).Row)
End With
With rngMaster
For Each cll In rngSearch
Set c = .Find(cll.Value2, LookIn:=xlValues)
If c Is Nothing Then
'MsgBox cll.Value2 & " not found in the SKU Reference List."
Sheets("NotFoundSKU").Range("A1") = cll.Value2
End If
Next
End With
End Sub
Try this, which incorporates comments above (to set rngMaster and rngSearch) and will list values not found in a list going down by finding the first empty cell.
Sub yg23iwyg()
Dim wst As Worksheet
Dim wet As Worksheet, c as range, cll as range
Set wst = Worksheets.Add
Set wet = Worksheets.Add
Set wrt = Worksheets.Add
wst.Name = "SKUReference"
wet.Name = "SKUNewList"
wrt.Name = "NotFoundSKU"
With Worksheets("Sheet1")
.Range(.Cells(1, "A"), .Cells(.Rows.Count, "B").End(xlUp)).Copy _
Destination:=wst.Cells(1, "A")
.Range(.Cells(1, "AA"), .Cells(.Rows.Count, "AZ").End(xlUp)).Copy _
Destination:=wet.Cells(1, "A")
'alternate with Union'ed range - becomes a Copy, Paste Special, Values and Formats because of the union
.Range("AA:AZ").Copy _
Destination:=wet.Cells(1, "A")
End With
Dim wksMaster As Worksheet, wksSearch As Worksheet
Dim rngMaster As Range, rngSearch As Range
Set wksMaster = Sheets("SKUReference")
Set wksSearch = Sheets("SKUNewList")
With wksMaster
Set rngMaster = .Range("A1:B" & .Range("B" & .Rows.Count).End(xlUp).Row)
End With
With wksSearch
Set rngSearch = .Range("A1:Y" & .Range("Y" & .Rows.Count).End(xlUp).Row)
End With
With rngMaster
For Each cll In rngSearch
Set c = .Find(cll.Value2, LookIn:=xlValues) 'i would consider adding more parameters here
If c Is Nothing Then
Sheets("NotFoundSKU").Range("A" & Rows.Count).End(xlUp)(2).Value = cll.Value2
End If
Next
End With
End Sub
I've created a range object by setting it from another range object's Rows(). When I reference the newly created range by row and column, it generates error 1004.
I can reference the original range by row and column. I've included checks to make sure the rng object points to the same range as the dataset object. When I inspect the rng object, the Value2 shows a single row of data.
Below is the minimum code I'm using that generates the error.
Private Sub TestRangeObject()
Dim i As Long
Dim dataset As Range
Dim rng As Range
Set dataset = sRoster.Range("B18:E37")
For i = 1 To dataset.Rows.Count
Set rng = dataset.Rows(i)
Debug.Print "Rng is Range Obj: " & (TypeOf rng Is Range)
Debug.Print "Same worksheet: " & (rng.Parent.CodeName = dataset.Parent.CodeName)
Debug.Print "Same address: " & (dataset.Rows(i).Address = rng.Address)
'can reference dataset object by row and column
Debug.Print "First column (dataset): " & dataset(i, 1).Address
'error when referencing rng object by row and column
Debug.Print "First column (rng): " & rng(1, 1).Address
Next i
End Sub
As additional detail: there's a difference between using Rows(somerow) and Range(somerange).
This can be validated with a simple example:
Sub Test()
Dim rng As Range
Set rng = Sheet1.Range("1:1")
Debug.Print rng(1, 1).Address ' returns $A$1
Dim rng2 As Range
Set rng2 = Sheet1.Rows(1)
Debug.Print rng2(1).Address ' succeeds, returns $1:$1
Debug.Print rng2(1, 1).Address ' fails
End Sub
The solution - to use Rows(myRow).Cells - has already been proposed.
EDIT:
In an attempt to capture and summarize some of the back and forth from comments, a Row, whether it's Range.Rows(somerow) or Sheet.Rows(somerow), refers to a unit as a row, not as individual cells.
For example, Range("A1:E10").Rows would refer to 10 rows, not 50 cells.
In the same way, Sheet1.Rows(1) refers to 1 row, not 16384 cells. The row is the "smallest unit of consideration," for lack of a better term. One row can't have a column index - it's just one row, not a collection of all the cells that make up that row, which each have their own column index.
So you'll need to use Cells if you specifically want to index the cells in a certain row.
You can't use:
rng(1, 1)
if rng is a single row range:
Sub jksfhsa()
Dim sRoster As Worksheet, dataset As Range, rng As Range
Set sRoster = Sheets("Sheet1")
Set dataset = sRoster.Range("B18:E37")
Set rng = dataset.Rows(1)
MsgBox dataset.Address
MsgBox dataset(1, 1).Address
MsgBox rng.Address
MsgBox rng(1, 1).Address
End Sub
The last MsgBox will fail.
However:
Sub jksfhsa()
Dim sRoster As Worksheet, dataset As Range, rng As Range
Set sRoster = Sheets("Sheet1")
Set dataset = sRoster.Range("B18:E37")
Set rng = dataset.Rows(1).Cells
MsgBox dataset.Address
MsgBox dataset(1, 1).Address
MsgBox rng.Address
MsgBox rng(1, 1).Address
End Sub
will work just fine. So in your code replace:
Set rng = dataset.Rows(i)
with:
Set rng = dataset.Rows(i).Cells