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
Related
I'm trying to create a tool in which I can select 2 files. In the first file (File1 in range B2) a few changes are made before looking up values in the second file (File2 in range B3) and paste them in the first file. I've created two buttons in the tool to select the files.
I want to a write code to lookup values in the second file but I'm getting different errors retrieving the information from the second second file. Can anyone help me with this?
I need to paste the values in the 8th row from the second file in the first file (same column) using the lookup value from the first column.
See code below: this is what I tried. Debugging needed in the vlookup subsection. Can anyone help me with this? Is there an easier way to lookup the values?
Sub Past_dues_button12345()
'Macro to create past due list daily
Dim wb1 As Excel.Workbook
Dim File As String
Dim File2 As String
File = Sheets("Tool").Range("B2")
File2 = Sheets("Tool").Range("B3")
Set wb1 = Workbooks.Open(File)
remove_repair
add_columns_with_comments
add_data_new_column
vlookup
pastevalues
Sharewb
End Sub
Sub add_columns_with_comments()
Columns("F:F").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("Table1[[#Headers],[Column3]]").Select
ActiveCell.FormulaR1C1 = "PN"
Range("Table1[[#Headers],[Column2]]").Select
ActiveCell.FormulaR1C1 = "MRPc"
Range("Table1[[#Headers],[Column1]]").Select
ActiveCell.FormulaR1C1 = "Comment"
End Sub
Sub vlookup()
Dim rw As Long, x As Range
Dim extwbk As Workbook, twb As Workbook
Set twb = ThisWorkbook
Workbooks("Tool_SO.XLSM").Activate
File2 = Sheets("Tool").Range("B3")
Set extwbk = Workbooks.Open(File2)
Set x = extwbk.Worksheets("Material Availability").Range("A1:H1000")
With twb.Sheets("Material Availability")
For rw = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(rw, 2) = Application.vlookup(.Cells(rw, 1).Value2, x, 8, False)
Next rw
End With
extwbk.Close savechanges:=False
End Sub
When using multiple workbooks, I avoid any usage of Applicationlevel functions, where possible, and try to remove any aspect of going back and fourth between workbooks.
As such, arrays will be your friend.
Here is the very simple model I have constructed, in Book1:
Based on said model, I am hoping to Match with Column 1 and Index with Column 2, within Book2 (ThisWorkbook).
There will be several items to dimension, including end rows/columns, the above array, the input terms, the output cells... but a good set-up carries the weight.
I will set this up in a single sub-routine for a single cell search term and output cell, noting that InputBoxes for workbook names, functions, etc., would make this more robust... the goal of my post is to give an example.
Here is the code I would generate to match within the above array (searchArray in my code), using a single cell for input/output:
Sub IndexFromExternalSearchSheetViaArray()
'Using External Workbook
Dim searchSheet As Worksheet
Set searchSheet = Workbooks("Book1").Worksheets(1)
With searchSheet
Dim searchSheetEndColumn As Long
searchSheetEndColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
Dim searchSheetEndRow As Long
searchSheetEndRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim searchArray As Variant
searchArray = .Range(.Cells(1, 1), .Cells(searchSheetEndRow, searchSheetEndColumn)).Value
End With
'Using This Workbook
Dim outputSheet As Worksheet
Set outputSheet = ThisWorkbook.Worksheets(1)
Dim searchTerm As Range
Set searchTerm = outputSheet.Cells(1, 1)
Dim outputCell As Range
Set outputCell = outputSheet.Cells(1, 2)
'Matching/Indexing with Array
Dim iterator As Long
For iterator = 1 To searchSheetEndRow Step 1
If searchTerm.Value = searchArray(iterator, 1) Then
Dim outputValue As String
outputValue = searchArray(iterator, 2)
Exit For
Else
If iterator = searchSheetEndRow Then outputValue = "No match found"
End If
Next iterator
'Final Output
outputCell.Value = outputValue
End Sub
With a single input, after running the code, I may have:
or:
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
I know this topic has been asked about before but nothing quite covers what I need. So here's the thing..
I have two workbooks. One is exported from another program which shows a staff member's Surname, first name, email and which ward they work on.
[Workbook1 example]
The second is the full staff list which has the same details but also a check list column.
[Workbook2 example]
What I need is a macro (probably a vlookup) which takes the information from the workbook1, checks against surname, first name and ward on workbook2 to ensure that it is the correct member of staff, copies the email onto workbook 2 and also fills the checklist column on workbook 2 to "Yes".
I'm afraid I am at a loss as to how to incorporate all of this together. Please help.
This is what I have so far but my knowledge is limited and did not know how to proceed.
Private Sub UpdateTraining_Click()
Dim I As Integer
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Ws3 As Worksheet
Dim Wb As Workbook
Dim CopyData As String
Dim RwCnt As Long
Dim RwCnt2 As Long
Dim Rw As Long
Dim Clm As Long
Dim SName As String
Dim FName As String
Dim Wrd As String
Dim vArr
Dim ClmLet As String
Set Ws1 = Workbooks("Nursing Docs Training Record.xlsm").Worksheets("Staff Training Record")
Set Ws2 = Workbooks("Nursing Docs Training Record.xlsm").Worksheets("Do Not Use")
Workbooks.Open ("C:\TypeformNursingDocumentation.xlsx")
Set Ws3 = Workbooks("TypeformNursingDocumentation.xlsx").Worksheets("tWeXNp")
RwCnt = Ws3.Cells(Rows.Count, 1).End(xlUp).Row
RwCnt2 = Ws1.Cells(Rows.Count, 1).End(xlUp).Row
Rw = Ws3.Range("F2").Row
Clm = Ws3.Range("F2").Column
Table1 = Ws3.Range("F2:F" & RwCnt)
vArr = Split(Cells(1, Clm).Address(True, False), "$")
ClmLet = vArr(0)
For Each cl In Table1
Ws3.Range(ClmLet & Rw).Select
SName = ActiveCell.Value
FName = ActiveCell.Offset(0, -1).Value
Wrd = ActiveCell.Offset(0, -4).Value
Rw = Rw + 1
Next cl
End Sub
You can achieve this with formulas but then you have to open Workbook1 for the formulas to work in Workbook2. So below approach uses VBA to achieve the results
Copy the below UDF in a module in Workbook2:
Sub UpdateMyList()
Dim oSourceWB As Workbook
Dim oSourceR As Variant
Dim iTotSRows&, iTotCRows&, iCC&, iSC&
Dim oCurR As Variant
Application.ScreenUpdating = False
' First lets get source data
Set oSourceWB = Workbooks.Open("C:\Temp\EmpLookup.xlsx", ReadOnly:=True) ' Change the source file name
With oSourceWB.Worksheets("Sheet1") ' Change the source sheet name
iTotSRows = .Range("A" & .Rows.count).End(xlUp).Row
oSourceR = .Range("A2:G" & iTotSRows)
End With
oSourceWB.Close False
' We now need the data from the sheet in this workbook to compare against
With ThisWorkbook.Worksheets("Sheet8") ' Change the sheet name to the sheet in your workbook
iTotCRows = .Range("A" & .Rows.count).End(xlUp).Row
oCurR = .Range("A2:H" & iTotCRows)
End With
' Next, lets compare and update fields
For iCC = 1 To UBound(oCurR)
For iSC = 1 To UBound(oSourceR)
If (oCurR(iCC, 1) = oSourceR(iSC, 6)) And (oCurR(iCC, 2) = oSourceR(iSC, 5)) And (oCurR(iCC, 5) = oSourceR(iSC, 2)) Then
oCurR(iCC, 7) = oSourceR(iSC, 7)
oCurR(iCC, 8) = "Yes"
Exit For
End If
Next
Next
Application.ScreenUpdating = True
' Finally, lets update the sheet
ThisWorkbook.Worksheets("Sheet8").Range("A2:H" & iTotCRows) = oCurR
End Sub
I've commented on the lines where you need to change references to workbook or worksheets. As long as you have updated the workbook and worksheet references, this should give you the desired results
I built the above UDF based on the columns as you provided in your question. If the columns change, you will have to modify the UDF or get the columns dynamically
You can use and If(Countif()) style function, where the countif checks for the presence of your value, and the if will return true if it is a match, then you can use the if true / false values accordingly. Let me know if you need more details but it could look something like this =IF(COUNTIF(The selected cell is in the selected range),"Yes", "No"). Then record this as a macro and copy the code into yours.
I'm pretty new at this and I've gone through a ton of bundle of tutorials but I can't seem to grasp the concept of how to achieve this result in excel VBA. I'll try being as detailed as possible.
I have a folder with 3 x Excel files -
Script.xlsx (Just a button that holds the script/macro)
WhiteCrown.xlsx (the workbook I'd like to copy the data from)
PackCon.xlsx (the workbook I'd like the data pasted into)
Concept:
If Workbook ("WhiteCrown.xlsx") contains value in Column B5:B10000 which = Workbook ("PackCon.xlsx") Column B5:B10000 AND Workbook ("WhiteCrown.xlsx") contains a value in Column E
There are 2 cells I don't want the value of E copied - "soy-milk" "Pepsi-max"
The check is to be looped till column b
Reaches 10000
:) thanks in advance
Sub ConvertData()
Dim i As Integer, n As Integer
Dim Desc As Range, ExDesc As Range
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rngLookup As Range
Dim v
Application.ScreenUpdating = False
Set wb1 = Workbooks.Open("C:\Users\amir.abdul\Desktop\Completed\New folder\WhiteCrown.xlsx")
Set ws1 = wb1.Sheets("BOMQ")
Set wb2 = Workbooks.Open("C:\Users\amir.abdul\Desktop\Completed\New folder\PackCon.xlsx")
With wb2.Sheets("("BOMQ")")
Set rngLookup = .Range(.Cells(7, 2), _
.Cells(7, 2).End(xlDown)).Resize(, 3)
End With
With ws1
i = 7
Do Until .Cells(i, 2) = ""
v = Application.VLookup(.Cells(i, 2).Value, rngLookup, 3, False)
If Not IsError(v) Then .Cells(i, 4).Value = v
i = i + 1
Loop
End With
wb2.Close False
End Sub
*Script updated but still not working
I do not Understand what data you would like to copy. I have exhibited the logic to do so. Tested and working.
Option Explicit
Private Sub btnScript_Click()
Dim WhiteCrown As Workbook, PackCon As Workbook, DestWorkbook As Workbook
Dim SheetWhiteCrown As Worksheet, SheetPack As Worksheet
Dim RowIndex As Long
Dim RngWhite As Range
Dim RngWhiteCount As Long
Dim ValBWhite, ValBPack, ValEWhite As String
Application.ScreenUpdating = False
Set WhiteCrown = Workbooks.Open("C:\Users\Mani\Desktop\Stackoverflow\WhiteCrown.xlsx")
Set SheetWhiteCrown = WhiteCrown.Sheets("BOMQ")
Set RngWhite = SheetWhiteCrown.Range("RngWhiteData")
RngWhiteCount = SheetWhiteCrown.Range("RngWhiteData").Rows.Count + 5
Set PackCon = Workbooks.Open("C:\Users\Mani\Desktop\Stackoverflow\PackCon.xlsx")
Set SheetPack = PackCon.Sheets("BOMQ")
Set DestWorkbook = Workbooks.Open("C:\Users\Mani\Desktop\Stackoverflow\Script.xlsx")
For RowIndex = 5 To RngWhiteCount
ValBWhite = SheetWhiteCrown.Cells(RowIndex, "B").Value
ValBPack = SheetPack.Cells(RowIndex, "B").Value
ValEWhite = SheetWhiteCrown.Cells(RowIndex, "E").Value
If Not ValBWhite = "" And ValBWhite = "" Then
If Not ((ValEWhite = "SoyMilk") Or (ValEWhite = "Pepsi")) Then
'Perform your copy to Destworkbook or vlookup or anything
Else
'Do Nothing
End If
End If
Next RowIndex
WhiteCrown.Close
PackCon.Close
DestWorkbook.Close False
End Sub
Never use hardocode ranges like Range("B10:E60"). Best coding practise involved using named ranges as in the above code(example "RngWhiteData" is named range). Add error validations.
If you're satisfied please vote this answer.
Regards,
Mani
I have a rather silly problem. I have a macro (linked to a button) which copies cells A1:A2 from one worksheet (namedFP) to another worksheet (Log). I intend to copy these 2 cells on the log sheet every time I hit the macro button. The problem I am facing right now is that when I use the button multiple times, these cells are getting copied over each other instead of using the next available row to paste the cells.
This is what I have now, and I tried changing the 'Rowcount+1' to 'RowCount+2' but that did not work. Any help is appreciated.
DHRSheet.Select
Range("A1:A2").Select
Selection.Copy
LogSheet.Select
RowCount = LogSheet.UsedRange.Rows.Count
Dim r As Integer
r = RowCount + 1
Dim infocell As Range
Set infocell = Cells(r, 1)
infocell.Select
ActiveSheet.Paste
infocell.Value = DHRSheet.Name & "$" & infocell.Value
DHRSheet.Select
ActiveWorkbook.Save
Is this what you are trying?
Sub Sample()
Dim LogSheet As Worksheet, DHRSheet As Worksheet
Dim lrow As Long
'~~> Change this as applicable
Set LogSheet = Sheets("Sheet1")
Set DHRSheet = Sheets("Sheet2")
With LogSheet
lrow = LogSheet.Range("A" & .Rows.Count).End(xlUp).Row + 1
DHRSheet.Range("A1:A2").Copy .Range("A" & lrow)
End With
End Sub
Here's a function I use that is very reliable and always returns the last row of a sheet without fail:
(possibly excessive for your simple use, but I always recommend it)
Public Function LastRowOfSheet(ByVal TestSheetNumber As Variant)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Input: Sheet index # or Sheet name
' Output: Last row of sheet.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim intNumberOfRowsInWorksheet As Long
intNumberOfRowsInWorksheet = Sheets(TestSheetNumber).UsedRange.Rows.Count
intNumberOfRowsInWorksheet = intNumberOfRowsInWorksheet + Sheets(TestSheetNumber).UsedRange.Row - 1
LastRowOfSheet = intNumberOfRowsInWorksheet
End Function
And I'd clean up your above code and use something like this:
Sub Move2RowsToEnd()
Dim iNextRowOfOutput As Long
Dim iRowNumber As Long
'- use the function to find the last row of the output sheet. we'll be pasting to the first row after.
iNextRowOfOutput = (LastRowOfSheet("Log") + 1)
'- you can adjust this for loop to loop through additional cells if you need to paste more than 2 rows in the future.
For iRowNumber = 1 To 2
'- for each row of input (2 total) set the value of the output sheet equal to it.
Sheets("Log").Range("A" & iNextRowOfOutput).Value = Sheets("namedFP").Range("A" & iRowNumber).Value
iNextRowOfOutput = iNextRowOfOutput + 1
Next iRowNumber
'- not sure which of these you want to save (one or both)
Sheets("namedFP").Save
Sheets("Log").Save
End Sub
Just paste the function above or below the Subroutine and let me know if you have any issues or questions regarding the 'Move2RowsToEnd' code.