So I have a contract with information that I wanted to update in different columns...I need to look up this contract in a list of contracts and override specific information with the user inputs.
I tried the code below. I could locate the location of the contract on the list however override doesn't work. Can you please help?
Sub UpdateChargesMacro3()
Dim contract As Double
Dim BR_Reduction As Double
Dim RIA_Reduction As Double
Dim TR_Reduction As Double
Dim PERA_Reduction As Double
Dim TPA_Reduction As Double
Dim JHHH_Reduction As Double
Dim RowCount As Integer
contract = Sheets("Input").Range("C29").Value
JHHH_Reduction = Sheets("Input").Range("C36").Value
Sheets("Final Summary").Select
With ActiveSheet.Range("C:C")
Set uRng = .Find(contract, , xlValues, xlWhole, , MatchCase:=False, searchformat:=False)
If uRng Is Nothing Then
MsgBox Prompt:="Contract not found!", Buttons:=vbInformation, Title:="OK"
End If
Exit Sub
If Not uRng Is Nothing Then
uRng.Activate
RowCount = ActiveCell.Row
Sheets("Final Summary").Range("DJ" & RowCount).value = JHHH_Reduction
End If
End With
End Sub
If uRng Is Nothing Then
MsgBox Prompt:="Contract not found!", Buttons:=vbInformation, Title:="OK"
End If
Exit Sub
Always exits the macro,
move exit inside the if statement
If uRng Is Nothing Then
MsgBox Prompt:="Contract not found!", Buttons:=vbInformation, Title:="OK"
Exit Sub
End If
Related
Have a column H with alphanumeric characters. Some cells in this column have the content (RAM) followed by 5 digits starting from 00000 to 99999.
If cell H219 has the content (RAM) 23596 then i have to fill cell A219 with a comment "completed".
This has to be done for all cells with the content "(RAM) followed by 5 digits"
Sub Macro16_B()
' ' Macro16_B Macro ' '
intRowCount = Worksheets("Reconciliation").UsedRange.Rows.Count
For i = 11 To intRowCount
If InStr(Range("H" & i).Value, "(RAM 00000-99999") Then
Range("A" & i).Value = "Completed"
End If
Next i
End Sub
A non-VBA answer could be (if the cell doesn't have extra text other than (RAM) & 5 numbers):
=IFERROR(IF(LEN(VALUE(TRIM(SUBSTITUTE(H1,"(RAM)",""))))=5,"completed",""),"")
My VBA answer would be:
Sub Test()
Dim rLastCell As Range
Dim rCell As Range
With Worksheets("Reconciliation")
Set rLastCell = .Columns(8).Find("*", , , , xlByColumns, xlPrevious)
If Not rLastCell Is Nothing Then
For Each rCell In .Range(.Cells(1, 8), rLastCell)
If rCell Like "*(RAM) #####*" Then
rCell.Offset(, -7) = "complete"
End If
Next rCell
End If
End With
End Sub
Cheers #Excelosaurus for heads up on the * would've forgotten it as well. :)
One way is to use the Like operator. The precise format of your string is not clear so you may have to amend (and assuming case insensitive). # represents a single number; the * represents zero or more characters.
Sub Macro16_B()
Dim intRowCount As Long, i As Long
' ' Macro16_B Macro ' '
intRowCount = Worksheets("Reconciliation").UsedRange.Rows.Count
For i = 11 To intRowCount
If Range("H" & i).Value Like "(RAM) #####*" Then
Range("A" & i).Value = "Completed"
End If
Next i
End Sub
Well, there are already 2 good answers, but allow me to paste my code here for good measure, the goal being to submerge #user2574 with code that can be re-used in his/her next endeavors:
Sub Macro16_B()
'In the search spec below, * stands for anything, and # for a digit.
'Remove the * characters if you expect the content to be limited to "(RAM #####)" only.
Const SEARCH_SPEC As String = "*(RAM #####)*"
Dim bScreenUpdating As Boolean
Dim bEnableEvents As Boolean
'Keep track of some settings.
bScreenUpdating = Application.ScreenUpdating
bEnableEvents = Application.EnableEvents
On Error GoTo errHandler
'Prevent Excel from updating the screen in real-time,
'and disable events to prevent unwanted side effects.
Application.ScreenUpdating = False
Application.EnableEvents = False
'Down with business...
Dim scanRange As Excel.Range
Dim cell As Excel.Range
Dim content As String
Dim ramOffset As Long
With ThisWorkbook.Worksheets("Reconciliation").Columns("H")
Set scanRange = .Worksheet.Range(.Cells(11), .Cells(.Cells.Count).End(xlUp))
End With
For Each cell In scanRange
content = CStr(cell.Value2)
If content Like SEARCH_SPEC Then
cell.EntireRow.Columns("A").Value = "Completed"
End If
Next
Recover:
On Error Resume Next
'Restore the settings as they were upon entering this sub.
Application.ScreenUpdating = bScreenUpdating
Application.EnableEvents = bEnableEvents
Exit Sub
errHandler:
MsgBox Err.Description, vbExclamation + vbOKOnly, "Error"
Resume Recover
End Sub
I use the standard finance cell formatting where inputs are blue, cells that reference anything offsheet are green, and everything else is black.
All well and good - I was capable of developing macros that basically do what the GoTo -> constants -> numbers and GoTo -> formulas and then looks within the formula text for a "!" symbol.
However is there a way to select and highlight (say, in purple) all cells that are used offsheet, regardless of whether they are input as constants or formulas or whatever on the original sheet?
ie: I'd like to be able to quickly find and identify any cells that are used offsheet via macro. I'm good at making macros in general, but just can't think up any functionality that would accomplish this. Can anyone give me a hint to get me started in the right direction?
EDIT: What I have so far:
Sub Offsheet_Dependents()
Dim xRg As Range
Dim xCell As Range
Dim xTxt As String
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select the data range:", "EDI macro", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
' Need to modify the below for loop to only highlight cells where the reference is offsheet. Currently higlights entire range.
' also need to add a cell.cleararrows command somewhere and have it work
For Each cell In xRg
cell.ShowDependents
Worksheet.cell.NavigateArrow TowardPrecedent:=False, ArrowNumber:=1, LinkNumber:=1
If ActiveCell.Worksheet.Name <> Worksheet.cell.Worksheet.Name Then
cell.Interior.Color = RGB(204, 192, 218)
End If
xRg.Select.ActiveSheet.ClearArrows
Next
End Sub
Another possibility, but the second macro doesn't successfully apply the first one across the range :( :
Sub Color_Dependents()
Dim rLast As Range, iLinkNum As Integer, iArrowNum As Integer
Dim stMsg As String
Dim bNewArrow As Boolean
Application.ScreenUpdating = False
ActiveCell.ShowDependents
Set rLast = ActiveCell
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
Do
Application.Goto rLast
On Error Resume Next
ActiveCell.NavigateArrow Towardprecedent:=False, ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
If Err.Number > 0 Then Exit Do
On Error GoTo 0
If rLast.Address(External:=True) = ActiveCell.Address(External:=True) Then Exit Do
bNewArrow = False
If rLast.Worksheet.Parent.Name = ActiveCell.Worksheet.Parent.Name Then
If rLast.Worksheet.Name = ActiveCell.Parent.Name Then
' local
stMsg = stMsg & vbNewLine & Selection.Address
Else
stMsg = stMsg & vbNewLine & "'" & Selection.Parent.Name & "'!" & Selection.Address
End If
Else
' external
stMsg = stMsg & vbNewLine & Selection.Address(External:=True)
End If
iLinkNum = iLinkNum + 1 ' try another link
Loop
If bNewArrow Then Exit Do
iLinkNum = 1
bNewArrow = True
iArrowNum = iArrowNum + 1 'try another arrow
Loop
rLast.Parent.ClearArrows
Application.Goto rLast
If stMsg Like "*!*" Then
ActiveCell.Interior.Color = RGB(204, 192, 218)
End If
End Sub
Sub Purple_Range()
Dim xRg As Range
Dim xCell As Range
Dim xTxt As String
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select the data range:", "EDI macro", xTxt, , , , , 8)
Set xRg = Application.Union(xRg, ActiveSheet.UsedRange)
If xRg Is Nothing Then Exit Sub
For Each cell In xRg
Call Color_Dependents
Next cell
End Sub
In Sub Purple_Range()
replace:
For Each cell In xRg
Cell.Select
Next cell
with:
For Each cell In xRg
Cell.Select
Call Color_Dependents
Next Cell
The reason why the second Macro was failing was because Color_Dependents() was updating the color of the current ActiveCell and Purple_Range() was cycling through the range with out updating the location of ActiveCell to make it current.
Otherwise the Macro was working fine.
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'm running the following macro to perform a basic 'FindHighlight' function through a database in MS XL 2003
The find function works perfectly, but the issue I have is that when the 'ClearHighlight' is used (before a search is made) then I get Run-time error 91 - 'Object variable or With block variable not set'
I understand that I need to complete a search before using this function, but others using the tool may not - I was wondering if there is a way to prevent this alert coming up?
(Beginner on VBA!!)
Thank you!
Dim FoundRange As Range
Sub FindHighlight()
Dim tempCell As Range, Found As Range, sTxt As String
sTxt = InputBox("Search string")
If sTxt = "False" Then Exit Sub
Set Found = Range("A1")
Set tempCell = Cells.Find(what:=sTxt, After:=Found, SearchDirection:=xlNext, MatchCase:=False)
If tempCell Is Nothing Then
MsgBox prompt:="Not found", Title:="Finder"
Exit Sub
Else
Set Found = tempCell
Set FoundRange = Found
End If
Do
Set tempCell = Cells.FindNext(After:=Found)
If Found.Row >= tempCell.Row And Found.Column >= tempCell.Column Then Exit Do
Set Found = tempCell
Set FoundRange = Application.Union(FoundRange, Found)
Loop
FoundRange.Interior.ColorIndex = 6
FoundRange.Font.ColorIndex = 3
End Sub
Sub ClearHighlight()
FoundRange.Interior.ColorIndex = xlNone
FoundRange.Font.ColorIndex = xlAutomatic
End Sub
If FoundRange is not set it's value is Nothing so:
Sub ClearHighlight()
if FoundRange is nothing then exit sub
FoundRange.Interior.ColorIndex = xlNone
FoundRange.Font.ColorIndex = xlAutomatic
End Sub
I have a table and I have the form I built.
the user pick a name and surname from the table by the combobox in form
the user need to choose from combobox "yes/no" about this name
I need a vba code (excel) so that it can find the name (after the user picked it) in the table
and then update the yes/no column by the correct row.
I created a module and added this:
Option Explicit
Public Sub update_sheet(workername As String)
'--> If the user was selected on the form update column F to Yes
Dim ws As Worksheet
Dim rowno As Long
Set ws = Sheets("workers")
With ws
rowno = .Range("C:C").Find(workername).Row
.Cells(rowno, 6).Value = "Yes"
End With
End Sub
On the form code:
Private Sub cb_select_change()
Call update_sheet(cb_select.Value)
End Sub
where your combo box is called cb_select
You'll need to do some work on this to make it into what you need, but it should get you started:
Private Sub CommandButton1_Click()
Dim rng_ToSearch As Excel.Range
Dim rng_Found As Excel.Range
On Error GoTo ErrorHandler
'Change this to the range that contains your names. I'm assuming that
'it's a single column and has the Yes/No column alongside.
Set rng_ToSearch = Sheet1.Range("MyTable_Names")
'Change the What argument to reflect the name of your form's
'control.
Set rng_Found = rng_ToSearch.Find(What:=Me.ComboBox1.Value, _
After:=rng_ToSearch.Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'This shouldn't happen if you've populated the name selection
'box correctly and have not allowed users to add to it.
'This is left as an exercise for the reader.
If rng_Found Is Nothing Then
Err.Raise vbObjectError + 2000, , "Either the selected name was " _
& "not found in the list, or no selection was made."
End If
'Again, change the control name to your own.
rng_Found.Offset(0, 1) = Me.ComboBox2.Value
ExitPoint:
On Error Resume Next
Set rng_ToSearch = Nothing
Set rng_Found = Nothing
On Error GoTo 0
Exit Sub
ErrorHandler:
MsgBox "Error in updating users: " & Err.Number & vbCrLf & Err.Description
Resume ExitPoint
End Sub
THIS IS MY CODE SO FAR
Private Sub RefEdit1_BeforeDragOver(Cancel As Boolean, ByVal Data As msforms.DataObject, ByVal x As stdole.OLE_XPOS_CONTAINER, ByVal y As stdole.OLE_YPOS_CONTAINER, ByVal DragState As msforms.fmDragState, Effect As msforms.fmDropEffect, ByVal Shift As Integer)
End Sub
Private Sub ClsFrmE_Click()
Unload Me
End Sub
Private Sub cmdAdd_Click()
Dim lRow As Long
Dim ws As Worksheet
Set ws = Worksheets("workers")
'???รท? ?? ?????? ?????
If Trim(Me.cmbWN.Value) = "" Then
Me.cmbWN.SetFocus
MsgBox "???? ?? ????"
Exit Sub
End If
If Trim(Me.tbDate.Value) = "" Then
Me.tbDate.SetFocus
MsgBox "???? ????? ?????"
Exit Sub
End If
'copy the data to the database
'use protect and unprotect lines,
' with your password
' if worksheet is protected
With ws
' .Unprotect Password:="password"
If Trim(Me.dNdcmb.Value) = "????" Then
.Cells(lRow, 6).Value = 1
Else
.Cells(lRow, 6).Value = 0
End If
.Cells(lRow, 7).Value = Me.tbDate.Value
'.Cells(lRow, 2).Value = Me.cboPart.List(lPart, 1)
' .Protect Password:="password"
End With
'clear the data
Me.cmbWN.Value = ""
Me.tbDate.Value = ""
Me.cmbWN.SetFocus
ActiveWorkbook.Save
End Sub
Private Sub UserForm_Initialize()
Dim cFullName As Range
Dim cDnd As Range
Dim ws As Worksheet
Set ws = Worksheets("workers")
For Each cFullName In ws.Range("??????")
With Me.cmbWN
.AddItem cFullName.Value
.List(.ListCount - 1, 1) = cFullName.Offset(0, 1).Value
End With
Next cFullName
For Each cDnd In ws.Range("??????????")
With Me.dNdcmb
.AddItem cDnd.Value
End With
Next cDnd
Me.dNdcmb.Text = Me.dNdcmb.List(Me.dNdcmb.ListCount - 2)
Me.cmbWN.SetFocus
End Sub