I know there have been a few questions on this - but i have tried the suggestions and it doesnt seem to work for me.
I get this issue on the offendind line.
Private Sub CommandButton1_Click()
Dim Live_Tracker
Set Live_Tracker = Worksheets("Live_Tracker")
Dim WIP
Set WIP = Worksheets("WIP")
Dim WR_FF
Set WR_FF = Worksheets("WR_FF")
Dim Historic
Set Historic = Worksheets("Historic")
Dim Lastrow As Integer
Dim LastrowLive As Integer
Dim x_track, x_wip As Double
Dim xt As Boolean
Dim count As Integer
'---------------------PASSWORD PROTECT----------------------------------
Dim MyPassword As Variant
Dim Password As String
Password = 123
MyPassword = Application.InputBox("Password Required to Run this Macro", "Password Required to Run this Macro")
If MyPassword = Password Then
Range("A1").Value = "This is a VBA Project Password Enabler"
Else
MsgBox "Incorrect Password"
End If
'____MAIN CODE______________________________________________________________
Lastrow = WIP.Cells(WIP.Rows.count, "A").End(xlUp).Row <<<<<<<< THIS LINE>>>>>>>>>>>
LastrowLive = Live_Tracker.Cells(Live_Tracker.Rows.count, "A").End(xlUp).Row
x_track = LastrowLive + 1
x_wip = 2
Related
Here is the code:
numLoansSoldPrev = Range("LoansSold:NewHedges").Cells.Count
If numLoansSoldPrev > 3 Then
Set rngLoansSoldStart = ActiveWorkbook.Sheets("Email").Range("LoansSold").Offset(1, 1)
Let strLoansSoldStart = rngLoansSoldStart.Address
Set rngLoansSoldEnd = ActiveWorkbook.Sheets("Email").Range("NewHedges").Offset(-2, 5)
Let strLoansSoldEnd = rngLoansSoldEnd.Address
Range(strLoansSoldStart & ":" & strLoansSoldEnd).Select
Selection.ClearContents
End If
The commands below the beginning of the if statement work just fine on their own, but every time I try to execute this, I get "block if without end if" despite clearly having one at the bottom.
I have numerous of these if statements in the file but they are all in the same format, so it's not like one if statement is missing an end if.
Any idea?
Expanded Code:
' DECLARE NEW LONGS VARIABLES
Dim numNewLoansPrev As Integer
Dim rngLoansStart As Range
Dim rngLoansEnd As Range
Dim strLoansStart As String
Dim strLoansEnd As String
' DECLARE NEW LOANS SOLD VARIABLES
Dim numLoansSoldPrev As Integer
Dim rngLoansSoldStart As Range
Dim rngLoansSoldEnd As Range
Dim strLoansSoldStart As String
Dim strLoansSoldEnd As String
' DECLARE NEW HEDGES VARIABLES
Dim numNewHedges As Integer
Dim rngNewHedgesStart As Range
Dim rngNewHedgesEnd As Range
Dim strNewHedgesStart As String
Dim strNewHedgesEnd As String
Dim xcess As Integer
' Active E-mail Tab
Worksheets("Email").Activate
' CLEAR EXCESS NEW LONG POSITIONS
numNewLoansPrev = Range("NewLongs:LoansSold").Cells.Count
If numNewLoansPrev > 3 Then
Set rngLoansStart = ActiveWorkbook.Sheets("Email").Range("NewLongs").Offset(1, 1)
Set strLoansStart = rngLoansStart.Address
Set rngLoansEnd = ActiveWorkbook.Sheets("Email").Range("LoansSold").Offset(-2, 5)
Set strLoansEnd = rngLoansEnd.Address
Range(strLoansStart & ":" & strLoansEnd).Select
Selection.ClearContents
End If
' CLEAR EXCESS SOLD LONG POSITIONS
numLoansSoldPrev = Range("LoansSold:NewHedges").Cells.Count
If numLoansSoldPrev > 3 Then
Set rngLoansSoldStart = ActiveWorkbook.Sheets("Email").Range("LoansSold").Offset(1, 1)
Set strLoansSoldStart = rngLoansSoldStart.Address
Set rngLoansSoldEnd = ActiveWorkbook.Sheets("Email").Range("NewHedges").Offset(-2, 5)
Set strLoansSoldEnd = rngLoansSoldEnd.Address
Range(strLoansSoldStart & ":" & strLoansSoldEnd).Select
Selection.ClearContents
End If
' CLEAR EXCESS NEW HEDGES POSITIONS
numNewHedges = Range("NewHedges:Pnl").Cells.Count
If numNewHedges > 3 Then
Set rngNewHedgesStart = ActiveWorkbook.Sheets("Email").Range("NewHedges").Offset(1, 1)
Set strNewHedgesStart = rngNewHedgesStart.Address
Set rngNewHedgesEnd = ActiveWorkbook.Sheets("Email").Range("PnL").Offset(-2, 5)
Set strNewHedgesEnd = rngNewHedgesEnd.Address
Range(strNewHedgesStart & ":" & strNewHedgesEnd).Select
Selection.ClearContents
End If
I have a problem updating certain modules. In some modules I can delete and import the modules, but on others what happens is that the module is imported first and the original deleted later which adds a 1 at the end of the module name and messes up the code.
Here's how I do it:
I have the following Excel file which I can track who needs or has updated to the new module version. When I update the module version I just type on the correct username column Not Updated. Once the user opens his MS Project it runs the following code and changes the value to Updated.
Then I run the following on Project.Activate in VBA - MS Project 2016 to check if the module needs to update.
Dim xlapp As Object
Dim xlbook As Object
Dim sHostName As String
Dim modulesList_loc As String
Dim projectVBA_loc As String
Dim modulesVBA_loc As String
projectVBA_loc = "\\sharedNetwork\Project\VBA\"
modulesVBA_loc = projectVBA_loc & "Modules\"
modulesList_loc = projectVBA_loc & "Modules Updates.xlsx"
' Get Host Name / Get Computer Name
sHostName = Environ$("username")
Set xlapp = CreateObject("Excel.Application")
SetAttr modulesList_loc, vbNormal
Set xlbook = xlapp.Workbooks.Open(modulesList_loc)
Dim rng_modules As Range
Dim rng_usernames As Range
Dim username As Range
Dim atualizado As Range
Dim module_name As Range
Dim lastcol As Long
Dim lastcol_letter As String
Dim linha As Integer
Dim len1 As Integer
Dim len2 As Integer
Dim module_name_short As String
Dim actualizar As Integer
'LAST USERNAME COLUMN
With xlbook.Worksheets(1)
'Last Column
lastcol = .Cells(2, .Columns.Count).End(xlToLeft).Column
lastcol_letter = GetColumnLetter(lastcol, xlbook.Worksheets(1))
End With
'Usernames range
Set rng_usernames = xlbook.Worksheets(1).Range("E2:" & lastcol_letter & "2")
'Finds the correct username
Set username = rng_usernames.Find(sHostName)
Set rng_modules = xlbook.Worksheets(1).Range("A3") 'First module
Do While rng_modules.Value <> Empty
'Adds module if necessary
linha = rng_modules.Row
Set atualizado = username.Offset(linha - 2)
Set module_name = rng_modules.Offset(, 1)
If atualizado.Value = "Not Updated" Then
With ThisProject.VBProject
len1 = Len(module_name.Value)
len2 = len1 - 4
module_name_short = Left(module_name.Value, len2)
On Error Resume Next
.VBComponents.Remove .VBComponents(module_name_short)
.VBComponents.import modulesVBA_loc & module_name.Value
End With
atualizado.Value = "Updated"
End If
Set rng_modules = rng_modules.Offset(1)
Loop
xlbook.Close (True)
SetAttr modulesList_loc, vbReadOnly
Add DoEvents after the Remove method is called to give time for the Remove method to complete.
'On Error Resume Next
.VBComponents.Remove .VBComponents(module_name_short)
DoEvents
.VBComponents.import modulesVBA_loc & module_name.Value
If the Remove method is failing, there is likely an error occurring, but the On Error Resume Next line is hiding the error. Comment out the On Error... line and see what the error is and handle it rather than ignore it.
I need some help with a vba code that will delete and entire row from a different sheet from the currently active one.
The code uses a userform to delete a row based upon a serial number entered into a text box. The rows to delete are duplicated on the sheet the userform is activated from as well as another. Below is an example I have tried which will delete the row of the current sheet but sends back an error for the second portion of code in the Else command.
Private Sub ScrapButton_Click()
Dim RTCNumber As String
RTCNumber = RTCTextBox
MSG1 = MsgBox("Remove " + RTCTextBox + " from Lab Stock?", vbYesNo)
If MSG1 = vbNo Then
Exit Sub
Else
Dim Row As Integer
Row = Application.WorksheetFunction.Match(RTCNumber, Sheet6.Range("A:A"), 0)
Rows(Row).EntireRow.Delete
Dim Row2 As Integer
Row2 = Application.WorksheetFunction.Match(RTCNumber, Sheet1.Range("A:A"), 0)
Sheets("Sheet1").Rows(Row2).EntireRow.Delete
End If
End Sub
Any help would be much appreciated, I am probably missing something obvious but I am fairly new to vba. I have tried several options and can't get it to work using a Worksheet.Activate function.
Thanks in advance.
James
Try to CLng the first argument of your match function. That works for me.
Had to remove WorksheetFunction on my version of Excel, but I don't know if that's the case on your machine, so I left it in.
And then, as manu stated in his answer, I added Sheet references.
Private Sub ScrapButton_Click()
Dim RTCNumber As String
RTCNumber = RTCTextBox
MSG1 = MsgBox("Remove " + RTCTextBox + " from Lab Stock?", vbYesNo)
If MSG1 = vbNo Then
Exit Sub
Else
Dim Row As Integer
Row = Application.WorksheetFunction.Match(Clng(RTCNumber), Sheets("Sheet6").Range("A:A"), 0)
Rows(Row).EntireRow.Delete
Dim Row2 As Integer
Row2 = Application.WorksheetFunction.Match(Clng(RTCNumber), Sheets("Sheets1").Range("A:A"), 0)
Sheets("Sheet1").Rows(Row2).EntireRow.Delete
End If
End Sub
Try this:
Private Sub ScrapButton_Click()
Dim RTCNumber As Double
Dim Row2 As Variant
Dim Row1 As Variant
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws6 As Worksheet
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1")
Set ws6 = wb.Sheets("Sheet6")
RTCNumber = RTCTextBox
MSG1 = MsgBox("Remove " & RTCNumber & " from Lab Stock?", vbYesNo)
If MSG1 = vbNo Then
Exit Sub
Else
Row1 = ws6.Application.WorksheetFunction.Match(RTCNumber, ws6.Range("A:A"), 0)
ws6.Rows(Row1).EntireRow.Delete
Row2 = ws1.Application.WorksheetFunction.Match(RTCNumber, ws1.Range("A:A"), 0)
ws1.Rows(Row2).EntireRow.Delete
End If
End Sub
Brilliant, thanks for the help!
Managed to get it working with Manu's answer with a couple tiny tweaks. It ended up like this:
Private Sub ScrapButton_Click()
Dim RTCNumber As String
Dim Row2 As Variant
Dim Row1 As Variant
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws6 As Worksheet
Set wb = ActiveWorkbook
Set ws1 = wb.Worksheets("Lab Stock")
Set ws6 = wb.Worksheets("Scrap")
RTCNumber = RTCTextBox
MSG1 = MsgBox("Remove " & RTCNumber & " from Lab Stock?", vbYesNo)
If MSG1 = vbNo Then
Exit Sub
Else
Row1 = ws6.Application.WorksheetFunction.Match(RTCNumber, ws6.Range("A:A"), 0)
ws6.Rows(Row1).EntireRow.Delete
Row2 = ws1.Application.WorksheetFunction.Match(RTCNumber, ws1.Range("A:A"), 0)
ws1.Rows(Row2).EntireRow.Delete
End If
End Sub
Much, much appreciated!
You can use more simple way to achieve required results using range.find method.
So, your code can looks like this:
Private Sub ScrapButton_Click()
Dim RTCNumber As String
Dim Cl As Range
RTCNumber = RTCTextBox
msg1 = MsgBox("Remove " + RTCTextBox + " from Lab Stock?", vbYesNo)
If msg1 = vbNo Then
Exit Sub
Else
With Sheets("Sheet1")
Set Cl = .[A:A].Find(RTCNumber, , xlValues, xlWhole)
If Not Cl Is Nothing Then Cl.EntireRow.Delete
End With
With Sheets("Sheet6")
Set Cl = .[A:A].Find(RTCNumber, , xlValues, xlWhole)
If Not Cl Is Nothing Then Cl.EntireRow.Delete
End With
End If
End Sub
If you still prefer usage of worksheetfunction then you shall know that if worksheetfunction.match couldn't find the search value then it will return error, worksheetfunctions shall be used only with error handling.
I have an Excel file for colleagues to extract reports from SQL server.
We created separate user and password for their department.
I have the module which shows the result of SQL query in an Excel file.
Here is working code:
Sub Button3_Click()
ActiveSheet.Cells.Clear
Dim qt As QueryTable
sqlstring1 = "SELECT * FROM dbo.ReportDataAdded ORDER BY ProductID, CountryCodeID"
With ActiveSheet.QueryTables.Add(Connection:=getConnectionStr2, Destination:=Range("A3"), Sql:=sqlstring1)
.Refresh
End With
End Sub
Private Function getConnectionStr2()
getConnectionStr2 = "ODBC;DRIVER={SQL Server};" & _
"DATABASE=em_CountryConsumer;" & _
"SERVER=192.192.192.192;" & _
"UID=UserName;" & _
"PWD=passwordd;"
End Function
I need to populate the result of another query into combo box. For that I need to get result of query into variable with dataset datatype.
How can I change my VBA code to do that?
Here is an example of how I have handled a similar problem in the past:
First here is a function to Query the database based with a given connection_string and query.
Function GetQuery(SQL As String, connect_string As String, Optional HasFields As Long = 0) As Variant
'''
' Returns: A Variant() Array with results from query.
'
' HasFields is an optional field to include the field names in the array
' Any integer in this field will include fields, leave it blank for just data
'''
Dim Conn As New ADODB.Connection
Dim RS As New ADODB.Recordset
Dim data_sheet As Worksheet
Dim R As Long, C As Long
Dim dbArr() As Variant
'''''''''''''''''''''''''''''
' Setting Up DB connection
'''''''''''''''''''''''''''''
conReTry:
On Error GoTo ConnectErr:
With Conn
.ConnectionString = connect_string
.Open
End With
ConnectErr:
If Err.Number <> 0 Then
MsgBox "There was an issue connecting to the Central DB."
Resume subexit
End If
On Error GoTo 0
''''''''''''''''''''''
' Starting the connection to DB
''''''''''''''''''''''
On Error GoTo QueryErr:
RS.Open SQL, Conn, adOpenStatic
QueryErr:
If Err.Number <> 0 Then
MsgBox "There was a problem with the Query. Could not get results from the statement:" & vbCrLf & Err.Description
dbArr = Array(" Failed Q ", " Failed Q ")
Resume subexit
End If
On Error GoTo 0
'''''''''''''''''''''
' Parse Data and fill array: DBarr
'''''''''''''''''''''
R = 0
#If VBA7 Then
Dim tmp_rowNum As LongPtr, tmp_colNum As LongPtr
Dim rowNum As Integer, colNum As Integer
tmp_rowNum = RS.RecordCount
tmp_colNum = RS.Fields.Count
rowNum = CLng(tmp_rowNum)
colNum = CLng(tmp_colNum)
#Else
Dim rowNum As Long, colNum As Long
rowNum = RS.RecordCount
colNum = RS.Fields.Count
#End If
If HasFields = 0 Then
ReDim dbArr(1 To rowNum + 1, 1 To colNum)
Else
ReDim dbArr(1 To rowNum + 2, 1 To colNum)
End If
Do While Not RS.EOF
R = R + 1
For C = 1 To RS.Fields.Count
If R = 1 And HasFields = 1 Then
dbArr(R, C) = RS.Fields(C - 1).Name
ElseIf Not R = 1 Then
dbArr(R, C) = RS.Fields(C - 1).Value
End If
Next
If Not R = 1 Then RS.MoveNext
Loop
subexit:
GetQuery = dbArr
Set Conn = Nothing
Set RS = Nothing
End Function
Next use the result of the Query (A [multi-dimensional] Array) to set the range in a worksheet:
Sub SetInitData()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim sql_string As String, connect_String as String
Dim ws as Worksheet
Set ws = ThisWorkbook.Sheets(config.DATA_SHEET_NAME)
sql_string = config.GET_INITIAL_PACKTYPE_QUERY
connect_string = config.MAIN_CONNECTION_STRING
Debug.Print sql_string
Dim packtypedata As Variant
packtypedata = GetQuery(sql_string)
ws.Range(ws.Cells(1, 1), ws.Cells(UBound(packtypedata), UBound(packtypedata, 2))).Value = packtypedata
'' Keep Total Rows for next routine explained below
Dim total_rows as Integer
total_rows = UBound(packtypedata)
SetComboBoxValues(total_rows)
''' Turn on events and screen updating again
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Finally you want to set the ComboBox:
Sub SetComboBoxValues(total_rows As Integer)
Dim ws as Worksheet, data_ws as Worksheet
Dim data_arr as Variant
Dim pack_dd as DropDown
Set ws = ThisWorkbook.Sheets(config.INPUT_SHEET_NAME)
Set data_ws = ThisWorkbook.Sheets(config.DATA_SHEET_NAME)
data_arr = data_ws.Range(data_ws.Cells(1,config.DATA_COL_DROPDOWN_INDEX),
data_ws.Cells(total_rows,config.DATA_COL_DROPDOWN_INDEX)).Value
Set pack_dd = ws.Shapes(config.MAIN_DATA_DROPDOWN_NAME).OLEFormat.Object
pack_dd.List = pack_dd
''' To set the index
pack_dd.ListIndex = 1
End Sub
** Note -- The GetQuery function has some kinks that I haven't had time to work out, namely I don't think the HasFields option to include headers actually works.
Also I'm using DropDowns, so I'm not sure if you are using the same type of object.
Good Luck
I'm just trying to do something very simple with Vlookup, but am getting the 1004 error. Would really, really appreciate your help. Thanks in advance. Here's my code:
Sub test()
Dim user As String
Dim drawn As String
Set Sheet = ActiveWorkbook.Sheets("consolidated")
For i = 2 To 2092
user = CStr(Cells(i, 1).Value)
Set Sheet = ActiveWorkbook.Sheets("sections")
drawn = CStr(Application.WorksheetFunction.VLookup(user, Sheet.Range("A2:B3865"), 2))
Set Sheet = ActiveWorkbook.Sheets("consolidated")
Cells(i, 10).Value = drawn
Next i
End Sub
When you use VLOOKUP as a member of WorksheetFunction, an error will result in a runtime error. When you use VLOOKUP as a member of Application, an error will result in a return value that's an error, which may or may not result in a runtime error. I have no idea why MS set it up this way.
If you use WorksheetFunction, you should trap the error. If you use Application, you should use a Variant variable and test for IsError. Here are a couple of examples.
Sub VlookupWF()
Dim sUser As String
Dim sDrawn As String
Dim shSec As Worksheet
Dim shCon As Worksheet
Dim i As Long
Set shSec = ActiveWorkbook.Worksheets("sections")
Set shCon = ActiveWorkbook.Worksheets("consolidated")
For i = 2 To 2092
sUser = shCon.Cells(i, 1).Value
'initialize sDrawn
sDrawn = vbNullString
'trap the error when using worksheetfunction
On Error Resume Next
sDrawn = Application.WorksheetFunction.VLookup(sUser, shSec.Range("A2:B3865"), 2, False)
On Error GoTo 0
'see if sdrawn is still the initialized value
If Len(sDrawn) = 0 Then
sDrawn = "Not Found"
End If
shCon.Cells(i, 10).Value = sDrawn
Next i
End Sub
Sub VlookupApp()
Dim sUser As String
Dim vDrawn As Variant 'this can be a String or an Error
Dim shSec As Worksheet
Dim shCon As Worksheet
Dim i As Long
Set shSec = ActiveWorkbook.Worksheets("sections")
Set shCon = ActiveWorkbook.Worksheets("consolidated")
For i = 2 To 2092
sUser = shCon.Cells(i, 1).Value
vDrawn = Application.VLookup(sUser, shSec.Range("A2:B3865"), 2, False)
'see if vDrawn is an error
If IsError(vDrawn) Then
vDrawn = "Not Found"
End If
shCon.Cells(i, 10).Value = vDrawn
Next i
End Sub