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
Related
I have a Cell range Sheets("INVOICE MAKER").Range("D18:D37") (Total 20 Cells), and a little UserForm with name Add Items.
In UserForm there are one Textbox and one Submit Button.
So if I write something in that Textbox and click on Submit Button, Data should be write to next available empty cell in range Sheets("INVOICE MAKER").Range("D18:D37"). And if all 20 cells are filled with data then show a message like "No more rows are available to write data".
Below code don't start writing data from Cell D18, its start writing data from D1.
and doesn't stop after cell D37.
Option Explicit
Dim lRow As Long
Dim ws As Worksheet
Set ws = Worksheets("INVOICE MAKER")
lRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
'check for a part number
If Trim(Me.Textbox.Value) = "" Then
Me.Textbox.SetFocus
MsgBox "Please Type Item Name"
Exit Sub
End If
With ws
.Cells(lRow, 5).Value = Me.Textbox.Value
End With
End Sub
Hope below code will help you:
Public Working_Sheet As Worksheet
Public All_Cell_Value As Boolean
Public Write_Cell_No As Integer
Public Content As String
'When button in the form is clicked
Sub Button1_Click()
Write_Content
End Sub
'validation and content writing function
Public Function Write_Content()
All_Cell_Value = True
Set Working_Sheet = Worksheets("Sheet1")
For i = 18 To 37
If Trim(Working_Sheet.Cells(i, "D")) = "" Then
All_Cell_Value = False
Write_Cell_No = i
Exit For
End If
Next i
If All_Cell_Value = False Then
Content = InputBox("Enter the value")
If Content = "" Then
MsgBox ("No Data")
Else
Working_Sheet.Cells(i, "D").Value = Content
End If
Else
MsgBox ("Sorry content is full")
End If
End Function
Maybe this will help!
EDIT #1
Fix some errors, and the code must to be inside a Form, with the TextBox and the Button
EDIT #2
Added a closing statement for the userform or the macro
Option Explicit
Private Sub CommandButton1_Click()
Dim lRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("INVOICE MAKER") 'Set from Thisworkbook
ws.Activate 'activate the Invoice Maker
'lRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
Dim iniCell As Integer: iniCell = 18
Dim endCell As Integer: endCell = 37
Dim setCol As Integer: setCol = ws.Range("D1").Column
'As you said, the range is D18:D37, then you can manipulate from this 3 vars
Dim iRange As Range
Dim i As Range
Dim isTheRangeFull As Boolean: isTheRangeFull = False
Dim iMsgbox As Integer
If Trim(Me.TextBox.Value) = "" Then
Me.TextBox.SetFocus
'Ask the user to retry or quit.
iMsgbox = MsgBox("Please Type Item Name" & Chr(10) & "Do you want to retry?", vbYesNo + vbDefaultButton1)
If iMsgbox = 6 Then
GoTo InsertData
'if the user say YES
'do it again
ElseIf iMsgbox = 7 Then
End
'if the user say NO
End If
End If
Set iRange = ws.Range(Cells(iniCell, setCol), Cells(endCell, setCol))
'set your working Range
'This Loop do the job!
For Each i In iRange
isTheRangeFull = True
'if there is no empty cell, won't enter the if, and
'the var continue TRUE, so there is no empty cells...
If i.Value = Empty Then
i.Value = Me.TextBox.Value
isTheRangeFull = False
'the Next line (End) Will close the Form and terminate the macro
'End
'The next line just close the userform
'Unload Me
'Decide which one to uncomment.
Exit For
End If
Next i
If isTheRangeFull Then
MsgBox "No more rows are available to write data"
End
End If
'With ws
' .Cells(lRow, 5).Value = Me.TextBox.Value
'End With
InsertData:
End Sub
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.
In a VBA Word macro, I'd like to get a Field-object for the field which contains the cursor.
The obvious try fails:
Private Sub Try1()
MsgBox Selection.Fields.Count
End Sub
The array is empty. Then I tried:
Private Sub Try2()
Dim oRange As Range
Set oRange = Selection.GoTo(What:=wdGoToField)
MsgBox oRange
End Sub
The cursor does not move, the message is empty.
I can iterate over ActiveDocument.Fields, compare the ranges and find the containing fiels. But probably there is a simple direct way?
My current production code with iteration over Document.Fields:
Sub Test()
Dim oField As Field
Set oField = FindWrappingField(Selection.Range)
If oField Is Nothing Then
MsgBox "not found"
Else
MsgBox oField
End If
End Sub
Private Function FindWrappingField(vRange As Range)
Dim oField As Field
Dim nRefPos As Long
' If selection starts inside a field, it also finishes inside.
nRefPos = vRange.Start
' 1) Are the fields sorted? I don't know.
' Therefore, no breaking the loop if a field is too far.
' 2) "Code" goes before "Result", but is it forever?
For Each oField In vRange.Document.Fields
If ((oField.Result.Start <= nRefPos) Or (oField.Code.Start <= nRefPos)) And _
((nRefPos <= oField.Result.End) Or (nRefPos <= oField.Code.End)) Then
Set FindWrappingField = oField
Exit Function
End If
Next oField
Set FindWrappingField = Nothing
End Function
The following function determines whether the selection spans or is within a field.
Function WithInField(Rng As Word.Range) As Boolean
' Based on code by Don Wells: http://www.eileenslounge.com/viewtopic.php?f=30&t=6622
' Approach : This procedure is based on the observation that, irrespective of _
a field's ShowCodes state, toggling the field's ShowCodes state _
twice collapses the selection to the start of the field.
Dim lngPosStart As Long, lngPosEnd As Long, StrNot As String
WithInField = True
Rng.Select
lngPosStart = Selection.Start
lngPosEnd = Selection.End
With Selection
.Fields.ToggleShowCodes
.Fields.ToggleShowCodes
' Test whether the selection has moved; if not, it may already have been _
at the start of a field, in which case, move right and test again.
If .Start = lngPosStart Then
.MoveRight
.Fields.ToggleShowCodes
.Fields.ToggleShowCodes
If .Start = lngPosStart + 1 Then
WithInField = False
End If
End If
End With
End Function
You can use the function with code like:
Sub TestWithInField()
Dim Rng As Word.Range, c As Word.Range, StrRslt As String
Set Rng = Selection.Range
For Each c In Rng.Characters
StrRslt = StrRslt & c.Text & ",WithInField:" & WithInField(Rng:=c) & vbCr
Next
Rng.Select
MsgBox StrRslt
End Sub
I had the same problem and I solved with the code below:
Sub Test()
NumberOfFields = Selection.Fields.Count
While NumberOfFields = 0
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
NumberOfFields = Selection.Fields.Count
Wend
End Sub
Of course, I have to know that the cursor is in a field.
Apparently, when you select a range extending to the right, at some moment the field will be selected. The end of the range doesn't count (it not acuses a field range)
I use this code
Sub GetFieldUnderCursor()
Dim NumberOfFields As Integer
Dim oFld As Field
Dim TextFeld As String
Dim Typ As Integer
Dim pos As Integer
Dim NameOfField As String
'update field. Cursor moves after the field
Selection.Fields.Update
'select the field
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
'check if there is a field
NumberOfFields = Selection.Fields.Count
If NumberOfFields = 0 Then
MsgBox "No field under cursor"
Exit Sub
End If
Set oFld = Selection.Fields(1)
TextFeld = Trim(oFld.Code.Text)
Typ = oFld.Type '85 is DOCPROPERTY, 64 is DOCVARIABLE
If Typ = 85 Or Typ = 64 Then
pos = InStr(15, TextFeld, " ")
If pos > 0 Then
NameOfField = Trim(Mid(TextFeld, 12, pos - 11))
MsgBox NameOfField
End If
End If
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 creating macro which will loop through column F and will delete month april from 2013. It seem that the macro is deleting all :-D. I dont know how to set it to delete only my criteria I tried (Month(Now) - 2). Mine date of format looks like DD/MM/YYYY.
Thank you for your help.
Sub Test1()
Dim rgFoundCell As Range
Dim toBeDeted As Range
Dim firstAddress
With Sheets("Sheet1").Range("F:F")
Set rgFoundCell = .Find(What:=(Month(Now) - 2))
If Not rgFoundCell Is Nothing Then
firstAddress = rgFoundCell.Address
Do
If toBeDeted Is Nothing Then
Set toBeDeted = rgFoundCell.EntireRow
Else
Set toBeDeted = Union(toBeDeted, rgFoundCell.EntireRow)
End If
Set rgFoundCell = .FindNext(rgFoundCell)
If rgFoundCell Is Nothing Then Exit Do
Loop While rgFoundCell.Address <> firstAddress
End If
End With
Application.ScreenUpdating = True
If Not toBeDeted Is Nothing Then _
toBeDeted.Delete ' Delete
End Sub
You can't use .Find in the way you think - it is only able to do text match or number match comparisons. This leaves you with having to cycle through each cell in the range and run your comparison explicitly on each cell
Sub Test1()
Dim toBeDeleted As Range
With Sheets("Sheet1").Range("F:F")
For Each c In .Cells
If Month(c.Value) = 3 And Year(c.Value) = 2013 Then
If toBeDeleted Is Nothing Then
Set toBeDeleted = c.EntireRow
Else
Set toBeDeleted = Union(toBeDeleted, c.EntireRow)
End If
End If
Next
End With
If Not toBeDeleted Is Nothing Then _
toBeDeleted.Delete ' Delete
End Sub
You might want to consider running the function on a more refined range than the full F column or use an end of data marker like checking for a blank row to stop the loop.
Try this:
Sub Test1()
On Error GoTo e
Application.ScreenUpdating = False
Dim rng As Range
Dim firstAddress
Set rng = Sheets("Sheet1").Range("F1", Sheets("Sheet1").Range("F1").End(xlDown))
Dim i As Long
i = 1
While i <= rng.Count
If Month(CDate(rng(i))) = 4 And Year(CDate(rng(i))) = 2014 Then
rng (i).EntireRow.Delete
Else
i = i + 1
End If
Wend
x:
Application.ScreenUpdating = True
Exit Sub
e:
MsgBox (Err.Description)
Resume x
End Sub
Maybe try to reduce the F:F range!!!