I am currently working on a spreadsheet and would like to utilize vlookup, but would prefer if it was through VBA.
I attached two screenshots of sheets, so you guys could visually see what i am trying to do.
Essentially I am trying to pull the "Priority" from sheet IW38 column K and place it on sheet "IW47" column R, but by using the order number as the matching info. The order numbers are in Column "E" in sheet IW47 and Column "A" in sheet IW47.
Below is the current macro I attempted to use:
Sub PriorityNUM()
'Variables----------------------------------------
'Defining WorkBook
Dim wb As Workbook
'Defining Sheets----------------------------------------------
'Working Asset Sheet
Dim IW47ws As Worksheet
'Sheet for Parts List Submission
Dim IW38ws As Worksheet
'Setting Worksheets
Set IW47ws = Sheets("IW47")
Set IW38ws = Sheets("IW38")
'Defigning Ranges within Worksheets----------------------------
Dim IW38rng As Range
'Setting Ranges within Submit Worksheets-------------------
Set IW38rng = IW38ws.Range("A:Z")
'Defining the Last Cell in Each Task Column----------------
Dim IW47last As Long
'Assigning Values to Last Row Variables
IW47last = IW47ws.Range("E" & Rows.Count).End(xlUp).Row
'Updating Drawings Identified---------------------------------------------------
Dim PriorityCell As Range
Dim PriorityLookup As String
For Each PriorityCell In IW47ws.Range("R:R")
If IsEmpty(DICell.Offset(0, -13).Value) Then
Exit For
End If
On Error Resume Next
PriorityLookup = WorksheetFunction.VLookup(PriorityCell.Offset(0, -13), IW38rng, 11, False)
If Err = 0 Then
PriorityCell.Value = PriorityLookup
Else
Err.Clear
End If
On Error GoTo 0
Next PriorityCell
End Sub
Any help would be greatly appreciated.
Thanks,
Juan
Readability
OP, your code can be restructured like below. I also used some short hand variables to make things easier. Your variable names would ideally be concise (easy to read and short to type). Readability goes a long way in troubleshooting.
Let me know once you have seen this so I can delete
Sub PNum()
Dim ws47 As Worksheet: Set ws47 = ThisWorkbook.Sheets("IW47")
Dim ws38 As Worksheet: Set ws38 = ThisWorkbook.Sheets("IW38")
Dim Arr As Range: Set Arr = ws38.Range("A:K")
Dim LR As Long, MyCell As Range, Priority As String
LR = ws47.Range("E" & ws47.Rows.Count).End(xlUp).Row
For Each MyCell In ws47.Range("R2:R" & LR)
If IsEmpty(MyCell.Offset(-13)) Then Exit Sub
On Error Resume Next
Priority = WorksheetFunction.VLookup(MyCell.Offset(, -13), Arr, 11, 0)
If Err = 0 Then
MyCell = Priority
Else
Err.Clear
End If
On Error GoTo 0
Next MyCell
End Sub
Related
I have a large sheet of data:
Updated Data
where i need to copy only a speacific part of this data to another worksheet:
The data i need to copy is always 4 cells wide however can be at any row and column. The first column cell at the top will allways be the same text value and i need to copy then from that found cell, 4 cells across to the right and then down to the cells are empty. All subsequent ranges after the first will use the same columns have several empty cells bother above and below each range needed. The macro will be run using a "button" so doesn't need to be checking the value of the cell all the time. The images are simplified versions of the data but are very accurate. 0 is used to show data surrounding range, HELLO is the data inside the range and INT_EXT_DOOR is my searched for cell value which can be in any column between data sets but will be the same inside each data set. The first range always starts at row 2.
Each range has to be numbered, defined by another worksheets cell value. For example, if my cell value is 1 i need it to copy range 1, if my value is 2 copy range 2 ect.
I have been trying to no luck to get anything that works like needed and would appreciate any help, thanks.
Test the next function, please:
Private Function testReturnBlock(strBlock As String, blkNo As Long)
Dim sh As Worksheet, ws As Worksheet, lastRow As Long, searchC As Range
Dim rng As Range
Set sh = ActiveSheet ' use here your sheet to be processed
Set ws = Worksheets("Return") 'use here your sheet where the data will be returned
Set searchC = sh.UsedRange.Find(strBlock)
If searchC Is Nothing Then MsgBox "No such a field in the worksheet...": Exit Function
lastRow = sh.Cells(Rows.Count, searchC.Column).End(xlUp).row
'The following part works well only if the blocks are separated by empty rows, as you said it is your sheet data case...
Set rng = sh.Range(searchC, sh.Cells(LastRow, searchC.Column)).SpecialCells(xlCellTypeConstants)
ws.Range("A1").Resize(rng.Areas(blkNo).Rows.Count, 4).Value = rng.Areas(blkNo).Resize(, 4).Value
End Function
The above function should be called like this:
Sub testRetBlock()
testReturnBlock "INT_EXT_DOOR", 2
End Sub
But in order to see that the correct range has been returned, you must adapt them in a way (in your test sheet), do differentiate. I mean the second one to contain "HELLO1" (at least on its first row), the following "HELLO2" and so on...
Try this routine if it does what you need. otherwise it should be a good start for adding whatever you need on top.
Option Explicit
Sub CopyBlock()
Dim wb As Excel.Workbook
Dim wsSource As Excel.Worksheet
Dim wsDest As Excel.Worksheet
Dim wsSelect As Excel.Worksheet
Dim lBlockNo As Long
Dim strCellID As String
Dim lBlock As Long
Dim lRow As Long
Dim lBlockRow As Long
Dim lBlockCol As Long
Dim searchRange As Excel.Range
Dim bRange As Excel.Range
Dim cRange As Excel.Range
Set wb = ActiveWorkbook
' set the worksheet objects
Set wsSource = wb.Sheets("Source")
Set wsDest = wb.Sheets("Dest")
Set wsSelect = wb.Sheets("Select") ' here you select which block you want to copy
' Identifier String
strCellID = "INT_EXT_DOOR"
' Which block to show. We assume that the number is in cell A1, but could be anywhere else
lBlockNo = wsSelect.Range("A1")
lRow = 1
' Find block with lBlockNo
For lBlock = 1 To lBlockNo
' Search the identifier string in current row
Do
lRow = lRow + 1
Set searchRange = wsSource.Rows(lRow)
Set bRange = searchRange.Find(strCellID, LookIn:=xlValues)
Loop While (bRange Is Nothing)
Next lBlock
lBlockRow = bRange.Row
lBlockCol = bRange.Column
' Search the first with empty cell
Do
lRow = lRow + 1
Loop While wsSource.Cells(lRow, lBlockCol) <> ""
' Copy the range found into the destination sheet
Range(Cells(lBlockRow, lBlockCol), Cells(lRow - 1, lBlockCol + 3)).Copy wsDest.Range("A1")
' Note the block copied
wsDest.Cells(1, 6) = "Block No:"
wsDest.Cells(1, 8) = lBlockNo
' Clean up (not absolutely necessary, but good practice)
Set searchRange = Nothing
Set bRange = Nothing
Set cRange = Nothing
Set wsSource = Nothing
Set wsDest = Nothing
Set wsSelect = Nothing
Set wb = Nothing
End Sub
Let me know if you need more help
I have 2 workbooks with data like this:
As seen, column A is my unique key to map the 2 workbooks. The values i want to populate are the "TBD" in the Raw file (image1). So i'm looking for key 11x in Master File and get values for column B, C & D (assembly, sub and part) for that key.
I "tried" match func but couldn't figure the destination to copy the search value and my code only returns one value at a time anyways...
for R = 2 To lastrow
y=application.match(worksheet2.cells(R,1), worksheet2.range("A:A"),0)
If not application.isnumber(y) Then
worksheet2.cells(x,1).copy destination:=worksheet1.cells(**?????????**)
So, can i return all three column values using one index match formula? If not how can i write the search function in VB? Please help.
This code is executed within the workbook where the search is initiated.
Private Sub CmdBtn_Click()
On Error GoTo workbookErr
Dim WbMaster As Worksheet: Set WbMaster = Workbooks("MasterWorkBook.xlsm").Worksheets("Sheet1")
Dim WbCopyTo As Worksheet: Set WbCopyTo = ThisWorkbook.Worksheets("Sheet1")
Dim rangeWbCopyTo As Range, rangeWbMaster As Range
Dim cellWbCopyTo As Range, cellWbMaster As Range
Dim i As Integer
With WbMaster
Set rangeWbMaster = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
With WbCopyTo
Set rangeWbCopyTo = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
For Each cellWbCopyTo In rangeWbCopyTo
For Each cellWbMaster In rangeWbMaster
If cellWbCopyTo.Value = cellWbMaster.Value Then
For i = 0 To 2
cellWbCopyTo.Offset(0, 1 + i).Value = cellWbMaster.Offset(0, 1 + i).Value
Next i
Exit For
End If
Next cellWbMaster
Next cellWbCopyTo
Exit Sub
workbookErr:
MsgBox "Open MasterWorkBook before executing the search.", vbCritical
End Sub
so i have some code that outputs this on a spreasheet:
what i want is that you see those empty columns i need them to be gone and have all the columns beside each other to save space.
so is there a way for me to check if a column is empty and if it is i need to pretty much cut and paste the next bunch of columns onto the empty ones WITH their properties such as color code and border.
any help is much appreciated, and thnx in advance. ^_^ :D
Try WorksheetFunction.CountA(Columns( *REF* )), replacing * REF * with the reference to each column (e.g. using variable and looping through)
If this = 0, the column is empty.
You can then just delete the empty columns, e.g. using If... Then in your loop.
(Have a look at:
http://analysistabs.com/excel-vba/delete-rows-columns/ for example)
Try this:
Sub DeleteColumns()
Dim rng As Range
Dim i As Long
Dim wkSht As Worksheet
Set wkSht = ThisWorkbook.Sheets("Sheet1") '--> enter your sheet name here
Set rng = wkSht.Range("A:Z") '--> set your range here
For i = rng.Columns.Count To 1 Step -1
If Application.CountA(Columns(i).EntireColumn) = 0 Then
Columns(i).Delete
End If
Next i
End Sub
You can also delete all the empty columns together using union as:
Sub DeleteColumns()
Dim rng As Range, delRng As Range
Dim i As Long
Dim wkSht As Worksheet
Set wkSht = ThisWorkbook.Sheets("Sheet2") '--> enter your sheet name here
Set rng = wkSht.Range("A:Z") '--> set your range here
For i = 1 To rng.Columns.Count
If Application.CountA(Columns(i).EntireColumn) = 0 Then
If delRng Is Nothing Then
Set delRng = Columns(i)
Else
Set delRng = Union(delRng, Columns(i))
End If
End If
Next i
delRng.Delete '--> delete all empty columns
End Sub
I am getting error messages i that state that variable isn't defined. And VB is coloring this code red If LCase(wb.Range("Q" & i) = "y" Then .AutoFilter and I don't know why.
It's really important that only rows with a "y" in column Q in each range is pasted, and not everything else.
I had to change i to 2 To 500, and j = 2 To 20, but am worried that I might get columns that I don't want pasted into Sheet2(Materials_Estimate). I just want the range columns to be pasted.
The ranges include Sheet2 information as shown in the picture below (B=text, c=text, D=text, F=up to 3 numbers, G=a letter y, H=text, I=a calculation copied from Sheet 1 of the qty*cost)
Can anyone assist me?
[Code]
Option Explicit
Sub Estimating2()
Application.ScreenUpdating = False
'naming the workbook and worksheets and ranges
Dim ProjectBudgeting1 As Workbook
Dim Materials_Budget As Worksheet
Dim Materials_Estimate As Worksheet
Dim LowesFax As Worksheet
Dim HomeDepotFax As Worksheet
Dim SBath1 As Range
Dim SBath2 As Range
Dim SBed1 As Range
Dim SBed2 As Range
Dim SBed3 As Range
Dim SBed4 As Range
Dim SHall As Range
Dim SFP As Range
Dim SRP As Range
Dim SKit As Range
Dim SGar As Range
Dim BuyOA As Range
Dim SFlorida As Range
Dim TargetRange As Range
Dim ActiveWorksheet As Worksheet
'naming the worksheets and ranges in code
Set ProjectBudgeting1 = ActiveWorkbook
Set Materials_Budget = Worksheets("Materials_Budget")
Set Materials_Estimate = Worksheets("Materials_Estimate")
Set LowesFax = Worksheets("LowesFax")
Set HomeDepotFax = Worksheets("HomeDepotFax")
Set SBath1 = Range("Materials_Budget!Supplies_Bathroom1")
Set SBath2 = Range("Materials_Budget!Supplies_Bathroom2")
Set SBed1 = Range("Materials_Budget!Supplies_Bedroom1")
Set SBed2 = Range("Materials_Budget!Supplies_Bedroom2")
Set SBed3 = Range("Materials_Budget!Supplies_Bedroom3")
Set SBed4 = Range("Materials_Budget!Supplies_Bedroom4")
Set SHall = Range("Materials_Budget!Supplies_Hallway")
Set SFP = Range("Materials_Budget!Supplies_FrontPorch")
Set SRP = Range("Materials_Budget!Supplies_RearPorch")
Set SKit = Range("Materials_Budget!Supplies_Kitchen")
Set SGar = Range("Materials_Budget!Supplies_Garage")
Set SFlorida = Range("Materials_Budget!Supplies_Florida")
'Here I'm calling out the column q and looking for a "Y"
Set BuyOA = Range("Materials_Budget!Buy_OrderApproval")
'Here I'm naming the source of the information that gets copied into other sheets
Set ActiveWorksheet = Materials_Budget
'Here is the sheet where the source cells are pasted
Set TargetRange = Range("Materials_Estimate!EstimateTableArea1")
'Looking for the "Y" in column q for duplicating and printing corresponding rows (i) and columns (j)
For i = 12 To 520
Cells("Q", i) = "Row " & i & " Col " & j
For j = 2 To 20
If LCase(wb.Range("Q" & i) = "y" Then .AutoFilter
i = i + 1
Range("Q" & i).Select
i = i - 1
Next q
Next i
For j = 1 To 5
Cells(i, j) = "Row " & i & " Col " & j
End Sub
Application.ScreenUpdating = True
End With
End Sub
[Code/]
I see many errors.
A) You have not declared your objects. For example, you need to declare SBath1, SBath2 etc.. as Range
B) You have declared ProjectBudgeting1 as workbook but then you are using it as a worksheet object.
C) When setting range, fully qualify them
D) Your wb object is undeclared. I would strongly suggest that you use Option Explicit at the top of your code
E) You have an extra bracket ) in wb.Range("Q12:Q" & LastRow))
F) Avoid the use of .Select INTERESTING READ
G) Finally, I would highly recommend on forgetting one word in vba and that is using End to stop a code. Reason is quite simple. It's like Switching your Computer using the POWER OFF button. The End statement stops code execution abruptly. Also the Object references held (if any) by other programs are invalidated.
Here is a basic gist on how your code should look like
Sub Estimating2()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng1 As Range, rng2 As Range
Set wb = ActiveWorkbook '~~> Or ThisWorkbook?
Set ws = wb.Sheets("Sheet1")
With ws
Set rng1 = .Range("Supplies_Bathroom1")
Set rng2 = .Range("Supplies_Bathroom2")
'
'~~> And so on
'
End With
End Sub
I am trying to make a vba program that will take the stock ticker in column A and paste it on a different "settings" sheet in a cell, then the program will execute two other vba codes that download historical data and backtest my formula. Then the program will return to the "data" sheet and print the value in "B10" on "settings" into column D in "data". I need the printed value to be in column d corresponding to the ticker's row. The program has to repeat 500 times. Can you help me find how to do this or point out what is wrong in my code? Thanks!
Sub finalbalance()
Dim ticker As Range
Dim i As Long
Sheets("results").Activate
Set ticker = ActiveCell
For i = 1 To 500
Sheets("results").Activate
ticker.Select
Selection.Copy
Sheets("Settings").Select
Range("B1").Select
ActiveSheet.Paste
Application.Run "datadownload"
Application.Run "btest"
ticker.Offset(0, 3) = Sheets("settings").Range("B10")
ticker.Address = ticker.Offset(1, 0)
Next i
End Sub
The problem is you can't assign a value to the .Address property:
'Instead of
ticker.Address = ticker.Offset(1, 0)
'Use:
Set ticker = ticker.offset(1, 0)
And that will get your code working as is. However, the select statements really aren't necessary and should be avoided. Here's a cleaned up version of the code:
Sub finalbalance()
Dim wsResults As Worksheet
Dim wsSettings As Worksheet
Dim rngStartCell As Range
Dim arrResults() As Variant
Dim lNumReps As Long
Dim i As Long
Set wsResults = Sheets("Results")
Set wsSettings = Sheets("Settings")
Set rngStartCell = wsResults.Range("A2")
lNumReps = 500
ReDim arrResults(1 To lNumReps)
For i = 1 To lNumReps
wsSettings.Range("B1").Value = rngStartCell.Offset(i - 1).Value
Application.Run "datadownload"
Application.Run "btest"
arrResults(i) = wsSettings.Range("B10").Value
Next i
rngStartCell.Offset(, 3).Resize(lNumReps).Value = Application.Transpose(arrResults)
End Sub