For each cell in 'myRange' I want to check for a range of values in Sheet2 and if the values in Sheet2 are found in myRange then for the corresponding row I want to put the value from Column A into Column E
As it stands, I'm only able to look for a single value from Sheet2 ("A1"). When attempting to extend this range I get errors.
Is there a way to make the range in Sheet2 dynamic, please?
Sub Find_values()
Dim myRange As Range
Dim Cell As Range
Dim LR As Long
LR = Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
Set myRange = Sheets(1).Range("B1:B" & LR)
For Each Cell In myRange
If Cell.Value = Sheets(2).Range("A1").Value Then Cell.Offset(0, 3) = Cell.Offset(0, -1).Value
Next Cell
End Sub
As others suggested, you can simply nest two For Each loops.
Sub Find_values()
Dim myRange1 As Range
Dim myRange2 As Range
Dim Cell1 As Range
Dim Cell2 as Range
Set myRange1 = Sheets(1).Range(range("B1"),range("B1").end(xlDown))
Set myRange2 = Sheets(2).Range(range("A1"),range("A1").end(xlDown)) 'This range is also dynamic and will adapt to teh number of entries you ahve in Sheet2
For Each Cell1 In myRange1
For Each Cell2 In myRange2
If Cell1.Value2 = Cell2.Value2 Then
Cell1.Offset(0, 3) = Cell1.Offset(0, -1).Value2
Exit for 'Save you some useless processing time since the entry has already been found
end If
Next Cell2
Next Cell1
End Sub
Note I have re-wrote your Range statment to be more cleaner.
Note I have also changed your .value statement into .value2, which depending on the type of data used in your cell will in some cases work better.
Follow this steps:
Convert the data in Sheet1 to an structured Excel table:
1- Select the range from scale's cell to the concatenate last cell
2- Click on the Ribbon "Home" | "Styles" | "Format as table" |
3- Check "My table has headers" box (mark it)
4- Write down the name of the table (While selecting one cell inside the table, look in the "Table tools" ribbon | "Table name"
5- Repeat the previous steps for the data in Sheet2
6- Add the following code to a VBA module:
Sub LookupValues()
' Define object variables
Dim sourceSheet As Worksheet
Dim sourceTable As ListObject
Dim sourceCell As Range
Dim dataSheet As Worksheet
Dim dataTable As ListObject
' Define other variables
Dim sourceSheetName As String
Dim sourceTableName As String
Dim dataSheetName As String
Dim dataTableName As String
' >>>>Customize this<<<<<
sourceSheetName = "Sheet2"
sourceTableName = "Table2"
dataSheetName = "Sheet1"
dataTableName = "Table1"
' Initialize worksheets
Set sourceSheet = ThisWorkbook.Worksheets(sourceSheetName)
Set dataSheet = ThisWorkbook.Worksheets(dataSheetName)
' Initialize source table
Set sourceTable = sourceSheet.ListObjects(sourceTableName)
Set dataTable = dataSheet.ListObjects(dataTableName)
' Loop through every cell in sourceSheet
For Each sourceCell In sourceTable.DataBodyRange.Columns(1).Cells
' >>>>Customize this<<<<<
' In the following code:
' Offset(0, 4) -> 4 stand for 4 columns after column A
' Index(dataTable.DataBodyRange.Columns(1) -> 1 stands to return the first column of the data table
' Match(sourceCell.Value, dataTable.DataBodyRange.Columns(2) -> 2 stands to look in the second column of the data table
If Not IsError(Application.Match(sourceCell.Value, dataTable.DataBodyRange.Columns(2), 0)) Then
sourceCell.Offset(0, 4).Value = Application.Index(dataTable.DataBodyRange.Columns(1), Application.Match(sourceCell.Value, dataTable.DataBodyRange.Columns(2), 0))
End If
Next sourceCell
End Sub
6- Customize the code to fit your needs
7- Test it and let us know if it works
Hope it helps!
Related
I wanted to copy all visible rows from sheet1 table1 to sheet2 table2 after filter if Column B is empty. The code I have below only copy the last data to the other sheet and it will copy to the rest of the table.
Sub Send()
Dim i As Integer, j As Integer, k As Integer
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim visRng As Range ' Creating a range variable to store our table, excluding any rows that are filtered out.
Set wsCopy = Application.ThisWorkbook.Worksheets("Sheet1")
Set wsDest1 = Application.ThisWorkbook.Worksheets("Sheet2")
MsgBox "Sending Form...."
Set visRng = Range("Table1").SpecialCells(xlCellTypeVisible) 'Check all visible Rows in Table1
Dim r As Range
For Each r In visRng.Rows ' Loop through each row in our visible range ...
'MsgBox (r.Row) ' ... and retrieve the "absolute" row number.
If wsCopy.Cells(r.Row, 2).Value = "" Then
wsCopy.Range("A" & r.Row).Copy
wsDest1.Range("Table2").Columns(1).PasteSpecial
End If
Next
End Sub
here is sample filter in Sheet1 Table1
here is the result of my code in Sheet2 Table2
Expected Result: Sheet2 Table2
This should work:
Sub Send()
Dim i As Integer, j As Integer, k As Integer
Dim wsCopy As Worksheet
'IN THE CODE wsDest WAS CALLED wsDest1. I CHANGED THE REFERENCES IN THE CODE. I'D SUGGET YOU TO USE Option Explicit.
Dim wsDest As Worksheet
Dim visRng As Range ' Creating a range variable to store our table, excluding any rows that are filtered out.
'ADDED A NEW VARIABLE
Dim DblRow As Double
Set wsCopy = Application.ThisWorkbook.Worksheets("Sheet1")
Set wsDest = Application.ThisWorkbook.Worksheets("Sheet2")
MsgBox "Sending Form...."
'CHANGED visRng TO TARGET ONLY THE FIRST COLUMN OF Table1. NO NEED TO INCLUDE THE REST OF THE TABLE; IT WOULD ONLY MAKE OUR EXECUTION LONGER
Set visRng = Range("Table1").Columns(1).SpecialCells(xlCellTypeVisible) 'Check all visible Rows in Table1
'YOU SHOULD PUT THIS DECLARATION AT THE BEGINNING. ALSO I'D SUGGEST NOT TO USE A SINGLE LETTER VARIABLE. wsDest IS A GOOD NAME FOR A VARIABLE.
Dim r As Range
'SETTING THE VARIABLE.
DblRow = 1
For Each r In visRng.Rows ' Loop through each row in our visible range ...
'MsgBox (r.Row) ' ... and retrieve the "absolute" row number.
If wsCopy.Cells(r.Row, 2).Value = "" Then
wsCopy.Range("A" & r.Row).Copy
'YOUR CODE DIDN'T SCROLL THE TABLE 2. USING DBLROW IN .Cells YOU CAN DO IT.
wsDest.Range("Table2").Cells(DblRow, 1).PasteSpecial
DblRow = DblRow + 1
End If
Next
End Sub
Edits highlighted by proper comments.
Report any question you have or bug you have encountered. If, according to your judgment, this answer (or any other) is the best solution to your problem you have the privilege to accept it (link).
So i want to make a loop where it checks the data in every cell in a column and if the cell has any type of data, it copy's the entire row to a different ss. If the cell is blank i need it to move onto the next cell below and not copy the row.
I have added some code below, im trying to copy all the rows in report1 in column H:H that have any input to Report3.
Sub GenerateReport3_Click()
Dim rep1 As Worksheet
Dim rep3 As Worksheet
Set rep1 = ThisWorkbook.Worksheets("Report1")
Set rep3 = ThisWorkbook.Worksheets("Report3")
Dim rngA As Range
Dim cell As Range
rep1.Range("A1:J1").Copy Destination:=rep3.Range("A1")
Set rngA = Sheets("Report1").Range("H:H")
For Each cell In rngA
If cell.Value = True Then
cell.EntireRow.Copy Destination:=rep2.Range("A" & Rows.Count).End(xlUp)(2)
End If
Next cell
End Sub
Every row in column in report 1 H:H that has any input needs to be copied to Report3.
Test for Not IsEmpty(...) rather than =TRUE.
Also, a few details around geting Range references need work (eg avoiding implicit references to ActiveSheet).
And don't loop over the entire 1,000,000+ rows in a column (That's so slow!)
Something like this
Sub GenerateReport3_Click()
Dim rep1 As Worksheet
Dim rep3 As Worksheet
Set rep1 = ThisWorkbook.Worksheets("Report1")
Set rep3 = ThisWorkbook.Worksheets("Report3")
Dim rngA As Range
Dim cell As Range
rep1.Range("A1:J1").Copy Destination:=rep3.Cells(1, 1)
With rep1
Set rngA = .Range(.Cells(1, "H"), .Cells(.Rows.Count, "H").End(xlUp))
For Each cell In rngA
If Not IsEmpty(cell) Then
cell.EntireRow.Copy Destination:=rep3.Cells(rep3.Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
Next cell
End With
End Sub
Note that if this is still too slow, there a are more ways to speed it up
I am trying to get the row number of a cell in a range that I specify with vba. I want to get the row number of the cell in the range but what I am getting is the row number of the cell in the worksheet.
This is the vba code I am using currently. I have set a range and within the range I search for a cell that contains the text string "C". Once I have found the cell I want to make changes to the value in the second column of the range.
Sub trial2()
Dim ActiveWB As Workbook
Dim ActiveWS As Worksheet
Dim rng As Range, findCell As Range
Set ActiveWB = ActiveWorkbook
Set ActiveWS = ActiveWB.ActiveSheet
Set rng = ActiveWS.Range("B4", "C10")
With rng
Set findCell = .Cells.Find(what:="C")
End With
rng.Cells(findCell.Row, 2).Value = "change to something."
End Sub
Before running the code:
After running the code:
the cell value that contains "C" is in the 6th row of the worksheet, but in the 3rd row of the range. I was wondering how do I get the 3rd row of the range. I am aware that I can just offset the cell by 1 column to solve this problem, but I am curious about getting row numbers of cells in respect to a defined range.
One option is to adjust based on the number of the first row of rng, using simple math.
rng.Cells(findCell.Row - rng.Row + 1, 2).Value = "change to something."
In this case 6 - 4 + 1 = 3.
You can use:
Option Explicit
Sub test()
Dim rng As Range
With ThisWorkbook.Worksheets("Sheet1")
'If your searching area for A,B,C etc is from B4 to B10 just use
Set rng = .Range("B4:B10").Cells.Find(what:="C")
'If your searching area for A,B,C etc is from B4 to C10 just use
Set rng = .Range("B4:C10").Cells.Find(what:="C")
If Not rng Is Nothing Then
'Way 1
.Cells(rng.Row, rng.Column + 1).Value = "change to something."
'Way 2
rng.Offset(0, 1).Value = "change to something."
Else
MsgBox "No ""C"" found."
End If
End With
End Sub
I'd like to select a specific number of cells in Sheet3 based on the count available in cell Z1 in Sheet2. The below code is somewhat of help, but not completely. The data in Sheet3 is a filtered range and I'd like to select only the visible cells (based on the count provided in Z1) below the header column in Sheet 3. Thanks in advance!
Sheets("Sheet3").Range("A1:X" & Sheets("Sheet2").Range("Z1").Value).Select
I assumed your headers take one row. Change HeaderRows accordingly.Private
Sub Test()
Dim myRange As Range, HeaderRows As Long
Dim newRange As Range, myArea As Range
Set myRange = Sheets("Sheet3").Range("A1:X" & Sheets("Sheet2").Range("Z1").Value)
'Change number of rows accordingly
HeaderRows = 1
With myRange
Set myRange = .Offset(HeaderRows, 0).Resize(.Rows.Count - HeaderRows, _
.Columns.Count).SpecialCells(xlCellTypeVisible)
End With
'Loop through each visible area
Set newRange = myRange.Areas(1)
For Each myArea In myRange.Areas
'Add area to a range
Set newRange = Application.Union(myArea, newRange)
Next
'Select new range
newRange.Select
End Sub
Here's what I have:
Response Flow
I have one sheet called Response Flow that has Response, Y/N and a Total. If the Response has a Y next to it I want to match the Response Name with the Response Name on Sheet 2 ("Campaigns") and insert a formula in the column next to the response name on Sheet 2 using VBA code. Below is what I have so far.
Sub Volume_Calc()
Dim LastRowR As Long
Dim LastRowC As Long
Dim LastRowI As Long
Dim LastRowA As Long
Dim rngFoundCell As Range
Dim cell As Range
Dim text As String
Dim FindRow As Range
LastRowR = Range("C65536").End(xlUp).Row
LastRowC = Range("K65536").End(xlUp).Row
LastRowI = Range("I65536").End(xlUp).Row
LastRowA = Range("A65536").End(xlUp).Row
Set FindRow = Worksheets("ResponseFlow").Range("C:C").Find(What:="Y",
LookIn:=xlValues)
Do While FindRow = True
If Application.Match(Worksheets("Campaigns").Range("K6"),
Worksheets("ResponseFlow").Range("A4:A" & LastRowA), 0) Then
Worksheets("Campaigns").Range("I6:I" & LastRowI).Formula = "=INDEX(ResponseFlow!$B$3:$B$145,MATCH(Campaigns!$K6,ResponseFlow!$A$3:$A$145,0))"
End If
Loop
End Sub
What you're intending to do seems like it'd be easier to do in Excel without VBA, but if you insist on having some macro insert formulas, this might be an easy approach. First put the dynamic formula you want to be pasting in to the right of the columns with a Y/N, SOMEWHERE in your sheet. In my example below I used Cell("Z1"). Make sure it's dynamic so that if you were to copy/paste formula into another cell, it would adjust correctly.
Again make sure whatever dynamic match formula you want to the right of your values is somewhere and configured to be dynamic. In my example it's on Response ws in cell Z1.
Sub Volume_Calc()
Dim Resp_WS As Worksheet: Set Resp_WS = Worksheets("ResponseFlow")
Dim CAMP_WS As Worksheet: Set CAMP_WS = Worksheets("Campaigns")
Dim rCell As Range
Dim cCell As Range
'Loops through Response Sheeet column "C" looking for values of "Y"
For Each rCell In Intersect(Resp_WS.Range("C:C"), WResp_WS.UsedRange).Cells
If UCase(rCell.Value) = "Y" Then
'When finds a cell with Y, it then loops through Campaigns Sheet column "I"
'looking for a value that matches one column to the left where the "Y" was found
For Each cCell In Intersect(CAMP_WS.UsedRange, CAMP_WS.Range("I:I")).Cells
'When match is found, the macro will insert the formula to the right
'of the cell in Campaigns, with the dynamically updated formula in cell Z1
If cCell.Value = rCell.offset(0,-1).Value Then
cCell.Offset(0, 1).FormulaR1C1 = Resp_WS.Range("Z1").FormulaR1C1
End If
Next cCell
End If
Next rCell
End Sub