I wrote a simple VBA code to automate writing of Vlookup formulas. After testing the code I noticed that it is not working correctly when I select a Range from a different workbook. It creates Vlookup formula as intented but it does not switch to initial workbook. It stays focused on a Workbook which I used to select a range. As much as i noticed while debuging it references the correct workbook and sheet but it does not change focus for some reason.
If anyone has any ideas I would appreciate it. Thank you.
Sub vlookup_easy()
Dim Rng As Range
Dim shOriginal As String
Dim wbOriginal As String
Dim frmWS As String
Dim frmWb As String
Dim sRange As String
Dim iColumn As Integer
shOriginal = ActiveSheet.Name
wbOriginal = ActiveWorkbook.Name
Set Rng = Application.InputBox(Prompt:="Unestie Range za Vlookup formulu", Title:="Vlookup", Default:=Selection.Address, Type:=8)
sRange = Rng.Address
frmWS = Rng.Parent.Name
frmWb = Rng.Parent.Parent.Name
iColumn = Application.InputBox(Prompt:="Unestie indeks kolone za Vlookup formulu", Title:="Vlookup", Default:=2, Type:=1)
ActiveCell.Formula = "=VLOOKUP(" & ActiveCell.Offset(0, -1).Address(False, False) & ",'[" & frmWb & "]" & frmWS & "'!" & sRange & "," & iColumn & ",FALSE)"
Workbooks(wbOriginal).Sheets(shOriginal).Activate 'this part is not working correctly
End Sub
I have the below code for one of my financial reports and I'm struggling with updating the code to make it more automated. The code creates a string of the column headers stored in multiple sheets. Each column header is a new tab in wb2. I can't figure out how to get formulas copied into a new address range. it needs to copy the values to that Sheet in wb2 and then move on to the next.
So the code needs to:
1/put the column headers to a string/array [Works]
2/look through string/array and find that column in wb1 [Works]
3/then copy specific ranges to wb2 (name is based of column header/string value) [Works]
4/copy formula into column G, based on row similar to what it does for column A addresses - for example if the range is G9, it needs to copy the formula H9-A9, etc
5/go to next value
Any help or direction would be appreciated.
Sub Prepare_CYTD_Report()
Dim addresses() As String
Dim addresses2() As String
Dim wb1 As Workbook, wb2 As Workbook
Dim my_Filename
'Declare variables for MHP60
Dim i As Long, lastcol As Long
Dim tabNames As Range, cell As Range, tabName As String
'Declare variables for MHP61
Dim i2 As Long, lastCol2 As Long
Dim tabNames2 As Range, cell2 As Range, tabName2 As String
'Declare variables for MHP62
Dim i3 As Long, lastCol3 As Long
Dim tabNames3 As Range, cell3 As Range, tabName3 As String
addresses = Strings.Split("A9,A12:A26,A32:A38,A42:A58,A62:A70,A73:A76,A83:A90", ",") 'Trial Balance string values
addresses2 = Strings.Split("G9,G12:G26,G32:G38,G42:G58,G62:G70,G73:G76,G83:G90", ",") 'Prior Month string values
Set wb1 = ActiveWorkbook 'Trial Balance to Financial Statements Workbook
'*****************************Load Column Header Strings
lastcol = wb1.Sheets("MHP60").Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames = wb1.Sheets("MHP60").Cells(4, 3).Resize(1, lastcol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP60", vbCritical
Exit Sub
End If
lastCol2 = wb1.Sheets("MHP61").Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames2 = wb1.Sheets("MHP61").Cells(4, 3).Resize(1, lastcol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP61", vbCritical
Exit Sub
End If
lastCol3 = wb1.Sheets("MHP62").Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames3 = wb1.Sheets("MHP62").Cells(4, 3).Resize(1, lastcol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP62", vbCritical
Exit Sub
End If
'*****************************Open CYTD/FYTD files
my_Filename = Application.GetOpenFilename(fileFilter:="Excel Files,*.xl*;*.xm*", Title:="Select File to create Reports")
If my_Filename = False Then
Exit Sub
End If
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(my_Filename)
'*****************************Copy values to Financial statements workbook
For Each cell In tabNames
tabName = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb1.Sheets("MHP60").Evaluate("ISREF('[" & wb2.Name & "]" & tabName & "'!$A$1)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName).Range(addresses(i)).Value2 = wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'wb2.Sheets(tabName).Range(addresses2(i)).Value2 =
'Debug.Print "data for " & wb2.Sheets(tabName).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName & " was not found in " & wb2.Name
End If
Next cell
For Each cell In tabNames2
tabName2 = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb1.Sheets("MHP61").Evaluate("ISREF('[" & wb2.Name & "]" & tabName2 & "'!$A$1)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName2).Range(addresses(i)).Value2 = wb1.Sheets("MHP61").Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'Debug.Print "data for " & wb2.Sheets(tabName2).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP61").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName2 & " was not found in " & wb2.Name
End If
Next cell
For Each cell In tabNames3
tabName3 = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb1.Sheets("MHP62").Evaluate("ISREF('[" & wb2.Name & "]" & tabName3 & "'!$A$1)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName3).Range(addresses(i)).Value2 = wb1.Sheets("MHP62").Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'Debug.Print "data for " & wb2.Sheets(tabName2).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP62").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName3 & " was not found in " & wb2.Name
End If
Next cell
Application.ScreenUpdating = True
End Sub
Sub Prepare_CYTD_Report()
Dim addresses() As String
Dim wb1 As Workbook, wb2 As Workbook
Dim i As Long, lastCol As Long, my_FileName
Dim tabNames As Range, cell As Range, tabName As String
addresses = Strings.Split("A12:A26,A32:A38,A42:A58,A62:A70,A73:A76,A83:A90", ",")
Set wb1 = ActiveWorkbook 'Trial Balance to Financial Statements
lastCol = wb1.Sheets("MHP60").Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames = wb1.Sheets("MHP60").Cells(4, 3).Resize(1, lastCol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP60", vbCritical
Exit Sub
End If
'*****************************Open CYTD/FYTD files
my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If my_FileName = False Then
Exit Sub
End If
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(my_FileName)
For Each cell In tabNames
tabName = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb2.Worksheets(1).Evaluate("ISREF('" & tabName & "'!$A$1)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName).Range(addresses(i)).Value2 = wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'Debug.Print "data for " & wb2.Sheets(tabName).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName & " was not found in " & wb2.Name
End If
Next cell
Application.ScreenUpdating = True
End Sub
In view of the observation made in my comment, the code presented above assumes that
the actual cell values on row 4 of MHP60 are the values 'as is' of
the actual tab names
those cell values were manually entered, i.e. not formula-driven
I need a VBA script that will perform a double FOR loop. The first FOR loop, is a loop that needs to perform a few commands over multiple sheets (The first sheet is the main sheet and needs to be skipped!!)
The second for loop needs to compare values on multiple rows. I have pasted my code so far...
Public Sub LoopOverSheets()
device = Cells(6, 1) 'This value is whatever the user chooses from a drop-down menu
Dim mySheet As Worksheet 'Creating variable for worksheet
orow = 8 'setting the starting output row
For Each mySheet In ThisWorkbook.Sheets 'this is the first FOR loop, to loop through ALL the worksheets
tabName = ActiveSheet.Name 'this is a variable that holds the name of the active sheet
For irow = 2 To 10 'This line of code starts the SECOND FOR loop.
If (Range("a" & irow)) = device Then 'This line of code compares values
orow = orow + 1
Range("'SUMMARY'!a" & orow) = device 'This line of code pastes the value of device variable
Range("'SUMMARY'!b" & orow) = tabName 'This line of code needs to paste the name of the current active sheet
'Range("'SUMMARY'!c" & orow) = Range("'tabName'!b" & irow) 'this line of code needs to paste whatever value is in the other sheet's cell
'Range("'SUMMARY'!d" & orow) = Range("'tabName'!c" & irow) 'same objective as the last line of code, different rows and columns
End If
Next irow 'This line of code will iterate to the next orow. This is where I get an error (Compile Error : Next Without For)*******
Next mySheet 'This line of code will iterate to the next sheet
End Sub
Currently the code runs, but it is only outputting results from the first (main sheet). It needs to skip the first sheet and iterate through the rest of them.
Update Summary Worksheet
Link: StrComp Function
The following is not tested.
The Code
Option Explicit
Sub loopOverSheets()
Const tName As String = "Summary"
Const tFirstRow As Long = 8
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim tgt As Worksheet
Set tgt = wb.Worksheets(tName)
Dim device As String
device = tgt.Cells(6, 1).Value
Dim tRow As Long
tRow = tFirstRow
Dim src As Worksheet
Dim sName As String
Dim i As Long
For Each src In wb.Worksheets
sName = src.Name
If Not StrComp(sName, tName, vbTextCompare) = 0 Then
For i = 2 To 10
If StrComp(src.Range("A" & i), device, vbTextCompare) = 0 Then
tRow = tRow + 1
tgt.Range("A" & tRow).Value = device
tgt.Range("B" & tRow).Value = sName
tgt.Range("C" & tRow).Value = src.Range("B" & i).Value
tgt.Range("D" & tRow).Value = src.Range("C" & i).Value
End If
Next i
End If
Next src
MsgBox "Data transferred.", vbInformation, "Success"
End Sub
Dim irow As Long
Dim ws As Worksheet
Dim mySheet As String
mySheet = "mainSheet" 'Insert in the mySheet variable the name of your main sheet
device = Cells(6, 1)
orow = 8
For Each ws In Application.ActiveWorkbook.Worksheets
If ws.Name <> mySheet Then
For irow = 2 To 10
If ws.Range("A" & irow) = device Then
orow = orow + 1
Range("'SUMMARY'!a" & orow) = device
Range("'SUMMARY'!b" & orow) = ws.Name
'Range("'SUMMARY'!c" & orow) = Range("'tabName'!b" & irow) 'this line of code needs to paste whatever value is in the other sheet's cell
'Range("'SUMMARY'!d" & orow) = Range("'tabName'!c" & irow) 'same objective as the last line of code, different rows and columns
End If
Next irow
End If
Next ws
I am interested in renaming my document's cell references to easily perform calculations in other sheets. In the below code I am trying to name cell Di to the concatenation of the text in Ci and the year. I am using the below code and getting an error:
Sub or Function Not Defined
Any ideas?
Sub Rename()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
For i = 1 To 50
Dim rng As Range
Dim str As String
Set rng = Range("D" & i)
rng.Name = Range("C" & i) & "_" & "2019"
Next i
End Sub
Where is the error application-defined or object defined error coming from? It seems to be coming from the formula that I created. Please help. It really should not be this hard to write code in VBA but for some reason it is not working.
Sub get_levels()
Dim Count As Integer
Dim ticker As Variant
Dim lastRow As Long
Dim lastRowC As Long
Dim rng As Range
Dim current_input_position As Long
Dim sheet As String
Dim mula As String
Dim updatedTicker As String
Application.CutCopyMode = False
Count = 0
sheet = "Test_Sheet"
current_input_position = 2
lastRow = Cells(Rows.Count, "A").End(xlUp).row
Label:
Set rng = Range("A" & current_input_position & ":A" & lastRow)
For Each ticker In rng.Cells
lastRowC = Cells(Rows.Count, "C").End(xlUp).row
updatedTicker = ticker & " A" & " Mtge"
MsgBox updatedTicker
mula = "GCBDC 2018-1A A Mtge"
Range("E2").formula = "=BDS(" & mula & ",""MTGE_CMO_GROUP_LIST"",""Headers=N"")"
Next ticker
End Sub
Assuming your Bloomberg Add-In is functional (try calling BDS manually from a regular worksheet to check), I think you may need to change this line:
Range("E2").formula = "=BDS(" & mula & ",""MTGE_CMO_GROUP_LIST"",""Headers=N"")"
to
Range("E2").Formula = "=BDS(""" & mula & """,""MTGE_CMO_GROUP_LIST"",""Headers=N"")"
If your variable mula has spaces in it (and even if it doesn't), it might need to have " on either side.
(Also, most of your Range and Cells references have no worksheet or workbook specified -- meaning they'll refer to whatever workbook and worksheet happens to be active whilst the code is running. Broadly speaking, you don't want this, but that wasn't your question.)