I am new to VBA Coding.I have an userform which retrieves the value from excel sheet.There is a combobox which retrieves the value.But i want to change the combobox value & save it in excel.....
Image for Data in Excel
Dim temp As String
Dim findid As String
Dim lkrange As Range
Set lkrange = Sheet6.Range("A:D")
findid = TextBox1.Value
On Error Resume Next
temp = Application.WorksheetFunction.Vlookup(findid, lkrange, 1, 0)
If Err.Number <> 0 Then
MsgBox "ID not found"
Else
MsgBox "ID found"
Label5.Caption = Application.WorksheetFunction.Vlookup(findid, lkrange, 2, 0)
Label6.Caption = Application.WorksheetFunction.Vlookup(findid, lkrange, 3, 0)
ComboBox1.Value = Application.WorksheetFunction.Vlookup(findid, lkrange, 4, 0)
End If
End Sub
Private Sub CommandButton2_Click()
Dim fid As String
Dim rowc As Integer
Dim rowv As Integer
fid = TextBox1.Value
rowc = Application.WorksheetFunction.Match(fid, Range("A:A"), 0)
rowv = rowc - 1
Cells(rowv, 4).Values = marktable.ComboBox1.Value
End Sub
you could try the following
Option Explicit
Private Sub CommandButton1_Click()
Dim lkrange As Range
Dim rng As Range
Set lkrange = ThisWorkbook.Sheets("Sheet6").Range("A:A")
With Me
Set rng = MyMatch(.TextBox1.Value, lkrange)
If rng Is Nothing Then
MsgBox "ID not found"
Else
MsgBox "ID found"
.Label5.Caption = rng.Offset(0, 1)
.Label6.Caption = rng.Offset(0, 2)
.ComboBox1.Text = rng.Offset(0, 3)
End If
End With
End Sub
Private Sub CommandButton2_Click()
Dim lkrange As Range
Dim rng As Range
Set lkrange = ThisWorkbook.Sheets("Sheet6").Range("A:A")
With Me
Set rng = MyMatch(.TextBox1.Value, lkrange)
If Not rng Is Nothing Then rng.Offset(0, 3).Value = .ComboBox1.Text
End With
End Sub
Private Function MyMatch(val As Variant, rng As Range, Optional matchType As Variant) As Range
Dim row As Long
If IsMissing(matchType) Then matchType = 0
On Error Resume Next
row = Application.WorksheetFunction.Match(val, rng, matchType)
If Err = 0 Then Set MyMatch = rng.Parent.Cells(rng.Rows(row).row, rng.Column)
End Function
there were some errors:
Sheet6.Range("A:D") is not vaild
if you want to point to a sheet named "Sheet6" belonging to the Workbook where the macro resides, then you have to use ThisWorkbook.Sheets("Sheet6").Range("A:A")
Cells(...,...).Values =... is not valid
you must use Cells(...,...).Value =
but I think the following suggestions are more important:
Always use Option Explicit statement at the very beginning of every module
this will force you to explicitly declare each and every variable, but then it'll save you lots of time in debugging process
avoid/limit the use of On Error Resume Next statement
and, when used, make sure to have it followed as soon as possible by the "On Error GoTo 0" one. that way you have constant control on whether an error occurs and where
I confined it in a "wrapper" function (MyMatch()) only.
Always specify "full" references when pointing to a range
I mean, Cells(..,..) implictly points to the active sheet cells, which may not always be the one you'd want to point to.
Related
is there I way for searching a value on the next sheet (ActiveSheet.Next.Activate) without jumping on to it?
Here the whole Code:
the problem is, it jumps to the next sheet even if there is no searched value.
Dim ws As Worksheet
Dim Loc As Range
Dim StrVal As String
Dim StrRep As String
Dim i As Integer
Private Sub CommandButton1_Click()
i = 1
Call Replacing
End Sub
Private Sub CommandButton2_Click()
i = 2
Call Replacing
End Sub
Public Sub Replacing()
StrVal = Userform1.Textbox1.Text
StrRep = Me.Textbox1.Text
if Trim(StrVal) = "" Then Exit Sub
Dim fstAddress As String
Dim nxtAddress As String
For Each ws In ThisWorkbook.Worksheets
With ws
Set Loc = .Cells.Find(what:=StrVal)
fstAddress = Loc.Address
If Not Loc Is Nothing Then
If Not StrRep = "" And i = 1 Then
Loc.Value = StrRep
Set Loc = .Cells.FindNext(Loc)
ElseIf i = 2 Then Set Loc = Range(ActiveCell.Address)
Set Loc = .Cells.FindNext(Loc)
nxtAddress = Loc.Address
If Loc.Address = fstAddress Then
ActiveSheet.Next.Activate '****Here it should jump only if found something on the next sheet****
GoTo repeat
nxtAddress = Loc.Address
End If
If Not Loc Is Nothing Then Application.Goto ws.Range(nxtAddress), False
End If
i = 0
End If
End With
Set Loc = Nothing
repeat:
Next ws
End Sub
the variable "i" which switches between the values 0, 1 and 2 is bound to two buttons. these buttons are "Replace" and "Skip (to next found value)".
This code asks on each occurrence of StrVal whether you want to replace the value or skip it.
I found a problem checking if Found_Address = First_Found_Address:
If you've replaced the value in in First_Found_Address it won't find that address again and miss the starting point in the loop.
Also the original source of the code stops at the last value using Loop While Not c Is Nothing And c.Address <> firstAddress. The problem here is that if the value in c is being changed eventually c will be Nothing but it will still try and check the address of c - causing an error (Range Find Method).
My solution to this is to build up a string of visited addresses on the sheet and checking if the current address has already been visited using INSTR.
I've included the code for calling from a button click or from within another procedure.
Private Sub CommandButton1_Click()
FindReplace Userform1.Textbox1.Text, 1
End Sub
Private Sub CommandButton2_Click()
FindReplace Userform1.Textbox1.Text, 1, Me.Textbox1.Text
End Sub
Sub Test()
FindReplace "cd", 1, "ab"
End Sub
Sub FindReplace(StrVal As String, i As Long, Optional StrRep As String = "")
Dim ws As Worksheet
Dim Loc As Range
Dim fstAddress As String
Dim bDecision As Variant
For Each ws In ThisWorkbook.Worksheets
'Reset the visited address list on each sheet.
fstAddress = ""
With ws
Set Loc = .Cells.Find(what:=StrVal, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Loc Is Nothing Then
Do
fstAddress = fstAddress & "|" & Loc.Address
Loc.Parent.Activate 'Activate the correct sheet.
Loc.Activate 'and then the cell on the sheet.
bDecision = MsgBox("Replace value?", vbYesNo + vbQuestion, "Replace or Select value?")
If bDecision = vbYes Then
Loc = StrRep 'Raise the blade, make the change.
'Re-arrange it 'til it's sane.
End If
Set Loc = .Cells.FindNext(Loc)
If Loc Is Nothing Then Exit Do
Loop While InStr(fstAddress, Loc.Address) = 0
End If
End With
Next ws
End Sub
Here is part of the code I am working on which is a part of a macro.
This is also the same on another file which is basically the same also.
The macro works on the other file while on the other, it doesn't and comes with the Run-time error '91'.
Attached is the code:
shtData.Activate
Dim r As Integer
Dim strassured As String
r = 1
While ActiveSheet.Cells(r, 1) <> ""
ActiveSheet.Cells(r, 1).Select
strassured = ActiveCell.Value
If shtWorkSpace.Range("B3").Value = strassured Then
If shtWorkSpace.Range("A60").Value = "Pending" Then
DataHandling.OverwriteDataTab (strassured)
Exit Sub
Else
MsgBox "This assured name is already in the database. Assured Names must be unique!", vbCritical
shtWorkSpace.Activate
ActiveSheet.Range("A1").Select
Exit Sub
End If
Else
r = r + 1
End If
Wend
I've added an answer, not to provide how to define and Set both worksheets (shtData and shtWorkSpace).
But also to provide a better coding practice, there is no need to Activate worksheets, or use Select and ActiveCell. Instead use fully qualified Ranges and Worksheets.
Code
Sub Test()
Dim shtData As Worksheet
Dim shtWorkSpace As Worksheet
Dim r As Integer
Dim strassured As String
Set shtData = Worksheets("Data") '<-- modify "Data" to your sheet name
Set shtWorkSpace = Worksheets("Workspace") '<-- modify "Workspace" to your sheet name
r = 1
While shtData.Cells(r, 1) <> ""
strassured = shtData.Cells(r, 1).Value
If shtWorkSpace.Range("B3").Value = strassured Then
If shtWorkSpace.Range("A60").Value = "Pending" Then
DataHandling.OverwriteDataTab (strassured)
Exit Sub
Else
MsgBox "This assured name is already in the database. Assured Names must be unique!", vbCritical
shtWorkSpace.Activate
ActiveSheet.Range("A1").Select '<-- not sure why you need to select the sheet and Range("A1")
Exit Sub
End If
Else
r = r + 1
End If
Wend
End Sub
I want to write a macro that will pick a particular value (in my case, stored in cell A1) from a dropdown list (in my case, in cell D6).
Here's what I have so far:
sr_par2 = Array ("TEXT", 'TEXT2", "TEXT3")
sr = Range("A1").Value
(...)
Dim i As Integer
i = 0
Range("D6").Select
Do While (sr <> ActiveCell.FormulaR1C1)
Range("D6").Select
ActiveCell.FormulaR1C1 = sr_par2(i)
i = i + 1
Loop
Is this what you are trying? I have commented the code so that you will not have a problem understanding it. Still if you do then simply ask :)
Sub Sample()
Dim ws As Worksheet
Dim rngIn As Range, rngOut As Range
Dim MyAr
Dim sFormula As String
Dim i As Long
'~~> Replace this with the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Set your input and output range here
Set rngIn = .Range("A1")
Set rngOut = .Range("D6")
'~~> Get the validation list if there is one
On Error Resume Next
sFormula = rngOut.Validation.Formula1
On Error GoTo 0
If sFormula = "" Then
'~~> If no validation list then directly populate the value
rngOut.Value = rngIn.Value
Else
'validation list TEXT1,TEXT2,TEXT3
MyAr = Split(sFormula, ",")
'~~> Loop through the list and compare
For i = LBound(MyAr) To UBound(MyAr)
If UCase(Trim(rngIn.Value)) = UCase(Trim(MyAr(i))) Then
rngOut.Value = MyAr(i)
Exit For
End If
Next i
'~~> Check if the cell is still blank. If it is then it means that
'~~> Cell A1 has a value which is not part of the list
If Len(Trim(rngOut.Value)) = 0 Then
MsgBox "The value in " & rngOut.Address & _
" cannot be set as the value you are copying is not part of the list"
End If
End If
End With
End Sub
If I understood correctly, this should do what you want :
sr_par2 = Array("TEXT", "TEXT2", "TEXT3")
sr = Range("A1").Value
Dim i As Integer
i = 0
On Error GoTo Handler
Do While (sr <> sr_par2(i))
i = i + 1
Loop
Range("D6").FormulaR1C1 = sr_par2(i)
Exit Sub
Handler:
MsgBox "Value not in the list", vbCritical + vbOKOnly, "Value not found"
I am struggling to find out how i can loop through all rows in excel from word. What I want to achieve is that if there is something in the WP column in excel then save the active worddocument with that filename. However i cant figure out something simple as getting the last row(might be empty rows in between), i just get error code 424, which according to MSDN does not give me any real hint whats wrong. Any ideas whats wrong?
Public Sub test()
Dim xlapp As Object
Set xlapp = CreateObject("Excel.Application")
myFileName = "Z:\Dokumentstyring\UnderArbeid\PARTSLIST.xlsm"
xlapp.Workbooks.Open myFileName
xlapp.Application.ScreenUpdating = False
xlapp.Visible = False
a = xlapp.sheets("List").Range("A1").Value
b = firstBlankRow(xlapp)
c = getColumn("WP", xlapp)
xlapp.Application.ScreenUpdating = True
xlapp.ActiveWorkbook.Close (True)
xlapp.Quit
Set xlapp = Nothing
End Sub
My function to receive the last row:
Function firstBlankRow(ByRef xlapp) As Long
'returns the row # of the row after the last used row
'Or the first row with no data in it
With xlapp.sheets("List")
'~~> Check if there is any data in the sheet
'If xlapp.WorksheetFunction.CountA(.Cells) <> 0 Then
firstBlankRow = .Range("A" & .Rows.Count).End(Excel.XlDirection.xlUp).Row
'Else
firstBlankRow = 1
'End If
End With
End Function
Here is my function for getting the column number
Public Function getColumn(header As String, ByRef xlapp) As Integer
Dim rng1 As Range
With xlapp.sheets("List")
Set rng1 = .Range(.Cells(1, 1), .Cells(1, Columns.Count)).Find(header, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
getColumn = rng1.Column
Else
MsgBox "Column " & header & " does not exist, Typo??", vbCritical
getColumn = -1
End If
End With
End Function
As per our conversation in the comments, change Dim Rng1 As Range to
Dim Rng1 As Object.
You can find the actual values of XlDirection, Xlvalues, xlwhole enums.
Preferably, it's better to do it like this:
Private Const xlUp as long = -4162
'and so on
Edit1:
Here's an adjusted function that solves your problem (I've tested it on my machine)
Public Function getColumn(header As String, ByRef xlapp) As Long
Dim rng1 As Object
With xlapp.sheets("List")
Set rng1 = .Range(.Cells(1, 1), .Cells(1, .Columns.Count))
If rng1 Is Nothing Then
MsgBox ("ERROR: Range object is empty.")
getColumn = -1
Exit Function
End If
For Each m In rng1
If m = "WP" Then
getColumn = m.Column
Exit Function
End If
Next m
MsgBox "Column " & header & " does not exist, Typo??", vbCritical
getColumn = -1
End With
End Function
I have a named range lstVendors that refers to: =OFFSET(Data!$W$2,0,0,COUNTA(Data!$W$2:$W$400),1). I want this range to be populated when the workbook opens. I have the following code for this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Range("lstVendors").Offset(0, 0).Value = "Please Select..."
' Set DropDown1 = ThisWorkbook.Sheets("Dashboard").DropDowns("Drop Down 1")
' DropDown1.Value = 1
On Error Resume Next
If Not IsError(Range("lstVendors")) Then
Range("lstVendors").ClearContents
End If
On Error GoTo 0
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
Set startRng = Range("lstVendors")
i = 0
For n = 2 To UBound(rslt)
Range("lstVendors").Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
It errors on the Set startRng = Range("lstVendors"). I know this is because there's nothing in the range when I'm trying to set it, because if I put one entry into the named range, the set works, however, I need it populated by the sqlite query on each open as the data changes.
Any suggestions much appreciated.
Try this. You have a dynamic range that doesn't evaluate after you clear the contents. To avoid this, there are probably several ways, but easy to simply hardcode the startRange variable so that it always points to Data!$W$2 address, which is (or rather, will become) the first cell in your lstVendors range.
Private Sub Workbook_Open()
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
Dim rngList As Range
'// Define your startRange -- always will be the first cell in your named range "lstVendors"
' hardcode the address because the dynamic range may not evalaute.
Set startRange = Sheets("Data").Range("W2")
'// Empty th lstVendors range if it exists/filled
On Error Resume Next
Range("lstVendors").Clear
On Error GoTo 0
'// Run your SQL query
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
i = 0
'// Print results to the Worksheet, beginning in the startRange cell
For n = 2 To UBound(rslt)
'Increment from the startRange cell
startRange.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
'Verify that "lstVendors" is being populated
Debug.Print Range("lstVendors").Address
Next n
End Sub
Thanks for the suggestions. Here is what I ended up doing in order to get around my problem. It involves adding something I didn't specify would be ok in my original question, so David's answer is great if what I did isn't an option. I first populated the first two cells in my named range with "Please Select..." and "All". In Sub Workbook_Open() we do this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
' Disable our not found message
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Set our start range to our named range
Set startRng = Range("lstVendors")
' Grab all vendor names
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
' Print result. Skip first two rows as constants "Please Select..." and "All" are populated there
i = 2
For n = 2 To UBound(rslt)
startRng.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
Then we will create Sub Workbook_BeforeClose:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' Disable the save changes dialog. This workbook will be locked up for display only. No need to confuse the user.
Application.DisplayAlerts = False
' Clear everything below the "Please Select..." and "All" cells in the named range
On Error Resume Next
Range("lstVendors").Offset(2, 0).ClearContents
On Error GoTo 0
' Save the changes to the named range
ThisWorkbook.Save
Application.DisplayAlerts = True
End Sub
This information is going to populate a drop down, so having Please Select and All hardcoded into the named range is acceptable for me. If that stipulation doesn't work for someone else looking at this in the future, please use David's suggestion! Thanks again!