I have rows in my Excel from RowA and RowX.
My intent is to find all items that start with "F" in ROWB and replace it with value 5 in ROWX, all others with have 31 in ROwX.
Sub ReplaceDashes()
Dim Cmcode As String
Dim Rownum As Long
Rownum = 6
With Range("B6")
Do Until Cells(Rownum, 2).Value = ""
Select Case Cells(Rownum, 2).Value
Case Left(.Text, 1) = "F"
Cells(Rownum, 24).Value = "5"
Case Else
Cells(Rownum, 24).Value = "31"
End Select
Rownum = Rownum + 1
Loop
End With
MsgBox ("DONE")
End Sub
The above does not work the way I wanted, it does not work for the first case, it replaces everything with "31" . Can some one suggest?
Edit: Found a solution. The select case has to be performed directly over left function:
Sub ReplaceDashes()
Dim Cmcode As String
Dim Rownum As Long
Dim mystr As String
Rownum = 6
With Cells(Rownum, 2)
Do Until Cells(Rownum, 2).Value = ""
mystr = Cells(Rownum, 2).Value
Select Case Left(mystr, 1)
Case "f"
Cells(Rownum, 24).Value = "5"
Case Else
Cells(Rownum, 24).Value = "31"
End Select
Rownum = Rownum + 1
Loop
End With
MsgBox ("DONE")
End Sub
Related
I am creating an Excel userform in which users can add, search, and update records. I was able to create a button command that searches the database (a single sheet in my workbook) and populates a listbox with the search results. Because my database has more than 10 columns which I wanted to be visible in the listbox, I used an array to populate the listbox rather than AddItem which limited me to 10 or fewer columns. (the search code is below)
Private Sub Search_Click()
''''''''''''Validation
If Trim(SearchTextBox.Value) = "" And Me.Visible Then
MsgBox "Please enter a search value.", vbCritical, "Error"
Exit Sub
End If
ReDim arrs(0 To 17, 1 To 1)
With Worksheets("Sheet1")
ListBox.Clear
ListBox.ColumnCount = 18
ListBox.ColumnHeads = True
ListBox.Font.Size = 10
ListBox.ColumnWidths = "80,80,150,130,90,90,80,80,80,80,80,60,70,150,150,150,150,180"
If .FilterMode Then .ShowAllData
Set k = .Range("K2:K" & Cells(Rows.Count, "K").End(xlUp).Row).Find(What:="*" & SearchTextBox.Text & "*", LookIn:=xlValues, lookat:=xlWhole)
If Not k Is Nothing Then
adrs = k.Address
Do
M = M + 1
ReDim Preserve arrs(0 To 17, 1 To M)
For j = 0 To 17
arrs(j, M) = .Cells(k.Row, j + 1).Value
Next j
Set k = .Range("K2:K" & Cells(Rows.Count, "K").End(xlUp).Row).FindNext(k)
Loop While Not k Is Nothing And k.Address <> adrs
ListBox.Column = arrs
Else
' If you get here, no matches were found
MsgBox "No matches were found based on the search criteria.", vbInformation
End If
End With
End Sub
I also added code so that when I double click on a record in the listbox, it populates the corresponding textbox in the userform.
Private Sub ListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1.Text = ListBox.Column(0)
If TextBox1.Text = ListBox.Column(0) Then
TextBox1.Text = ListBox.Column(0)
TextBox2.Text = ListBox.Column(1)
TextBox3.Text = ListBox.Column(2)
TextBox4.Text = ListBox.Column(3)
TextBox5.Text = ListBox.Column(4)
TextBox6.Text = ListBox.Column(5)
TextBox7.Text = ListBox.Column(6)
TextBox8.Text = ListBox.Column(7)
TextBox9.Text = ListBox.Column(8)
TextBox10.Text = ListBox.Column(9)
TextBox11.Text = ListBox.Column(10)
TextBox12.Text = ListBox.Column(11)
TextBox13.Text = ListBox.Column(12)
TextBox14.Text = ListBox.Column(13)
TextBox15.Text = ListBox.Column(14)
TextBox16.Text = ListBox.Column(15)
TextBox17.Text = ListBox.Column(16)
TextBox18.Text = ListBox.Column(17)
End If
End Sub
After double clicking on a search result from the listbox, I want users to be able to edit any information in those textboxes and click a command button to update that entry/record in the database itself. However, I am having some problems with creating this function. I used the following code, and although it doesn't return an error message, it doesn't change the entry in the database.
Dim X As Long
Dim Y As Long
X = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For Y = 2 To X
If Sheets("Sheet1").Cells(Y, 11).Value = SearchTextBox.Text Then
Sheets("Sheet1").Cells(Y, 1).Value = TextBox1
Sheets("Sheet1").Cells(Y, 2).Value = TextBox2
Sheets("Sheet1").Cells(Y, 3).Value = TextBox3
Sheets("Sheet1").Cells(Y, 4).Value = TextBox4
Sheets("Sheet1").Cells(Y, 5).Value = TextBox5
Sheets("Sheet1").Cells(Y, 6).Value = TextBox6
Sheets("Sheet1").Cells(Y, 7).Value = TextBox7
Sheets("Sheet1").Cells(Y, 8).Value = TextBox8
Sheets("Sheet1").Cells(Y, 9).Value = TextBox9
Sheets("Sheet1").Cells(Y, 10).Value = TextBox10
Sheets("Sheet1").Cells(Y, 11).Value = TextBox11
Sheets("Sheet1").Cells(Y, 12).Value = TextBox12
Sheets("Sheet1").Cells(Y, 13).Value = TextBox13
Sheets("Sheet1").Cells(Y, 14).Value = TextBox14
Sheets("Sheet1").Cells(Y, 15).Value = TextBox15
Sheets("Sheet1").Cells(Y, 16).Value = TextBox16
Sheets("Sheet1").Cells(Y, 17).Value = TextBox17
Sheets("Sheet1").Cells(Y, 18).Value = TextBox18
End If
Next Y
Additionally, the term that I am searching with is not unique, so there are multiple records/rows in the database with the same search term. How can I create this code in a way that I when I click on the update button, information from the userform (which has been populated by doubleclicking the record in the listbox) is updated in the excel sheet but not for all records with the same search term?
Thank you so much for any help!
Add a Label to your UserForm to hold the row number from where the text box values came. Use the first column (width zero so hidden) of the listbox to hold the row number of the filtered rows. Set the label to column 0 of the double clicked row.
Option Explicit
Private Sub Update_Click()
Dim r As Long, n As Long
' record showing
r = Val(Label1.Caption)
If r < 1 Then
Exit Sub
End If
With Sheets("Sheet1")
For n = 1 To 18
.Cells(r, n).Value2 = Me.Controls("TextBox" & n)
Next
End With
End Sub
Private Sub ListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim n As Long
With ListBox
For n = 1 To ListBox.ColumnCount - 1
Debug.Print n, .Column(n)
Me.Controls("TextBox" & n).Text = .Column(n)
Next
Label1.Caption = .Column(0)
End With
End Sub
Private Sub Search_Click()
Const COLS = 18
Dim s
s = Trim(SearchTextBox.Value)
If s = "" And Me.Visible Then
MsgBox "Please enter a search value.", vbCritical, "Error"
Exit Sub
Else
s = "*" & s & "*"
End If
Dim rngFnd As Range, rngSearch As Range, first As String
Dim arr, lastrow As Long, i As Long, j As Long
' search sheet
With Worksheets("Sheet1")
If .FilterMode Then .ShowAllData
lastrow = .Cells(.Rows.Count, "K").End(xlUp).Row
Set rngSearch = .Range("K1:K" & lastrow)
i = WorksheetFunction.CountIf(rngSearch, s)
If i > 0 Then
ReDim arr(0 To COLS, 1 To i)
Set rngFnd = rngSearch.Find(What:=s, LookIn:=xlValues, lookat:=xlWhole)
If Not rngFnd Is Nothing Then
i = 0
first = rngFnd.Address
Do
i = i + 1
arr(0, i) = rngFnd.Row
For j = 1 To COLS
arr(j, i) = .Cells(rngFnd.Row, j).Value
Next j
Set rngFnd = rngSearch.FindNext(rngFnd)
Loop While rngFnd.Address <> first
End If
Else
'If you get here, no matches were found
MsgBox "No matches were found based on the search criteria. " & s, vbExclamation
Exit Sub
End If
End With
' format listbox
With ListBox
.Clear
.ColumnCount = COLS + 1
.ColumnHeads = True
.Font.Size = 10
.ColumnWidths = "0,80,80,150,130,90,90,80,80,80,80,80,60,70,150,150,150,150,180"
.Column = arr
End With
End Sub
Trying to build a Select Case statement that does a similar job to a nested if function. Essentially I want to give a cell a value (in Column i + 1) based on values of two columns (column P and column I) and then apply it to a down the whole column of numbers down to the lastrow (hence lr variable)
Currently, I am getting type mismatch error on the select case line.
Dim i As Long
Dim RowNum As Long
Dim lr As Long
Set i = 10
RowNum = 2
lr = Worksheets("1").cells.Find("*", cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row
Set tbl = ActiveSheet.ListObjects("1")
Do Until cells(RowNum, i + 1) = lr
Select Case cells(RowNum, "P") And cells(RowNum, "I").Value
Case Is = "1" And "Available"
cells(RowNum, i + 1).Value = "Purchase"
Case Is = "2" And "Not Available"
cells(RowNum, i + 1).Value = "Attempt Purchase"
Case Is = "3"
cells(RowNum, i + 1).Value = "Purchase Automatic"
Case Is = "4"
cells(RowNum, i + 1).Value = "Do not Purchase"
Case Else
cells(RowNum, i + 1).Value = "N/A"
End Select
RowNum = RowNum + 1
Loop
Any help is greatly appreciated. Thanks
Multi Select Case
Select Case needs one expression. Handle the other with an If statement.
Snippet
Select Case Cells(RowNum, "P")
Case Is = "1"
If Cells(RowNum, "I").Value = "Available" Then
Cells(RowNum, i + 1).Value = "Purchase"
End If
Case Is = "2"
If Cells(RowNum, "I").Value = "Not Available" Then
Cells(RowNum, i + 1).Value = "Attempt Purchase"
End If
Case Is = "3"
Cells(RowNum, i + 1).Value = "Purchase Automatic"
Case Is = "4"
Cells(RowNum, i + 1).Value = "Do not Purchase"
Case Else
Cells(RowNum, i + 1).Value = "N/A"
End Select
If you had read up on how the Select Case structure works you would realise that the way you are structuring your Select Case is not possible. In the VBA IDE put the cursor on Select and Press F1. This will bring up the help page of Select Case.
To achieve something similar to what you need to achieve you will need to concatenate the two values to give a single value and adjust the case values accordingly. The code below assumes that "CStr(Cells(RowNum, "I").Value" is equivalent to "" where necessary for the Case labels in the Case structure to work correctly.
You should also be aware that 'Set i' is incorrect as I is a value variable and not a reference variable. Use i=10.
Dim i As Long
Dim RowNum As Long
Dim lr As Long
i = 10
RowNum = 2
lr = Worksheets("1").Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row
Set tbl = ActiveSheet.ListObjects("1")
Do Until Cells(RowNum, i + 1) = lr
Select Case Trim$(CStr(Cells(RowNum, "P").Value) & CStr(Cells(RowNum, "I").Value))
Case "1Available"
Cells(RowNum, i + 1).Value = "Purchase"
Case Is = "2Not Available"
Cells(RowNum, i + 1).Value = "Attempt Purchase"
Case Is = "3"
Cells(RowNum, i + 1).Value = "Purchase Automatic"
Case Is = "4"
Cells(RowNum, i + 1).Value = "Do not Purchase"
Case Else
Cells(RowNum, i + 1).Value = "N/A"
End Select
RowNum = RowNum + 1
Loop
Sub a()
Dim i As Integer
For i = 1 To 8
If Cells(i, 1).Value = "M" Then
Cells(i, 2).Value = ""
End If
Next i
End Sub
You need to include the sheet information along with the cells.
Example: Sheet1.Cells(i,1).Value or Worksheets("Sheet name").Cells(i,1).Value
I'm sure I've just made a school boy error but i just can't see it :(
I have a user form that searches a worksheet(sheet 2) and displays the results in a list box but the code will only work when excel is visible and the sheet being searched selected. Any advice would be greatly received :)
Private Sub Branch_Search_Button_Click()
'branch search
Dim rownum As Long
Dim searchrow As Long
Sheet5.Range("A2:C9999").ClearContents
rownum = 2
searchrow = 2
Do Until Sheet2.Cells(rownum, 1).Value = ""
If InStr(1, Sheet2.Cells(rownum, 2).Value, TextBox1.Value, vbTextCompare) > 0 Then
Sheet5.Cells(searchrow, 1).Value = Cells(rownum, 1).Value
Sheet5.Cells(searchrow, 2).Value = Cells(rownum, 2).Value
Sheet5.Cells(searchrow, 3).Value = Cells(rownum, 3).Value
searchrow = searchrow + 1
End If
rownum = rownum + 1
Loop
If searchrow = 2 Then
MsgBox "Area not found"
Exit Sub
End If
ListBox2.RowSource = "Area_Search!a1:c" & Range("c" & Rows.Count).End(xlDown).Row
End Sub
That was it! thanks for your help Super Symmetry really appreciated!!! :D
Potential solution
You should fully qualify all your ranges. The following might fix your error. Please note the comments starting with '*
Private Sub Branch_Search_Button_Click()
'branch search
Dim rownum As Long
Dim searchrow As Long
Sheet5.Range("A2:C9999").ClearContents
rownum = 2
searchrow = 2
Do Until Sheet2.Cells(rownum, 1).Value = ""
If InStr(1, Sheet2.Cells(rownum, 2).Value, TextBox1.Value, vbTextCompare) > 0 Then
'* Change Sheet2 to the appropriate sheet code
Sheet5.Cells(searchrow, 1).Value = Sheet2.Cells(rownum, 1).Value
Sheet5.Cells(searchrow, 2).Value = Sheet2.Cells(rownum, 2).Value
Sheet5.Cells(searchrow, 3).Value = Sheet2.Cells(rownum, 3).Value
searchrow = searchrow + 1
End If
rownum = rownum + 1
Loop
If searchrow = 2 Then
MsgBox "Area not found"
Exit Sub
End If
'* change Sheet5 to the appropriate sheet code
ListBox2.RowSource = "Area_Search!a1:c" & Sheet5.Range("c" & Rows.Count).End(xlDown).Row
End Sub
Recently, I have been trying to code a VBA to assist me in summing a column and divide by counter to get average. However, I have a new requirement that is it is only going to sum up those that are visible. Any idea on how should I proceed? Below is my code,
Sub test3()
Dim FinalRow As Long
Dim Row As Long
Dim counter As Integer
Dim total As Double
counter = 3
total = 0
Dim i As Double
FinalRow = Range("C65536").End(xlUp).Row
For Row = 3 To FinalRow
If Not IsEmpty(ActiveSheet.Cells(counter, "C")) And Not IsEmpty(ActiveSheet.Cells(Row + 1, "C")) Then
If ActiveSheet.Cells(counter, "B").Value = True Then
ActiveSheet.Cells(Row, "M").Value = 100
For i = counter To Row
If IsEmpty(ActiveSheet.Cells(i, "F")) Then
With ActiveSheet.Cells(i, "F")
.Value = Now
.NumberFormat = "dd/mm/yy"
If (.Value - .Offset(0, 2).Value) >= 0 Then
.Font.color = vbRed
Else
.Font.color = vbBlack
End If
End With
End If
Next i
End If
If (ActiveSheet.Cells(Row, "L").Value = 100) Then
For i = counter To Row
If IsEmpty(ActiveSheet.Cells(i, "F")) Then
With ActiveSheet.Cells(i, "F")
.Value = Now
.NumberFormat = "dd/mm/yy"
If (.Value - .Offset(0, 2).Value) >= 0 Then
.Font.color = vbRed
Else
.Font.color = vbBlack
End If
End With
End If
Next i
End If
If Not (ActiveSheet.Cells(counter, "B").Value) = True Then
ActiveSheet.Cells(counter, "M").Value = (Application.Sum(Range(ActiveSheet.Cells(counter, "L"), ActiveSheet.Cells(Row, "L")))) / (Row + 1 - counter)
End If
counter = Row + 1
End If
Next
End Sub
This testcode works for me, just change it as you need it:
Sub TestSumme()
Dim Summe As Long
Summe = Application.WorksheetFunction.Sum(ThisWorkbook.Sheets(1).Range("A1:A6").SpecialCells(xlCellTypeVisible))
MsgBox (Summe)
End Sub