This is not a question, so much as a solution, but I wanted to share it here as I had gotten help for things I needed here.
I wanted to find a specific Excel sheet, in the Active Workbook, searching by the name of the sheet. I built this to find it. It is a "contains" search, and will automatically go to the sheet if it is found, or ask the user if there are multiple matches:
To end at any time, just enter a blank in the input box.
Public Sub Find_Tab_Search()
Dim sSearch As String
sSearch = ""
sSearch = InputBox("Enter Search", "Find Tab")
If Trim(sSearch) = "" Then Exit Sub
'MsgBox (sSearch)
Dim sSheets() As String
Dim sMatchMessage As String
Dim iWorksheets As Integer
Dim iCounter As Integer
Dim iMatches As Integer
Dim iMatch As Integer
Dim sGet As String
Dim sPrompt As String
iMatch = -1
iMatches = 0
sMatchMessage = ""
iWorksheets = Application.ActiveWorkbook.Sheets.Count
ReDim sSheets(iWorksheets)
'Put list of names in array
For iCounter = 1 To iWorksheets
sSheets(iCounter) = Application.ActiveWorkbook.Sheets(iCounter).Name
If InStr(1, sSheets(iCounter), sSearch, vbTextCompare) > 0 Then
iMatches = iMatches + 1
If iMatch = -1 Then iMatch = iCounter
sMatchMessage = sMatchMessage + CStr(iCounter) + ": " + sSheets(iCounter) + vbCrLf
End If
Next iCounter
Select Case iMatches
Case 0
'No Matches
MsgBox "No Match Found for " + sSearch
Case 1
'1 match activate the sheet
Application.ActiveWorkbook.Sheets(iMatch).Activate
Case Else
'More than 1 match. Ask them which sheet to go to
sGet = -1
sPrompt = "More than one match found. Please enter number from following list"
sPrompt = sPrompt + "to display the sheet" + vbCrLf + vbCrLf + sMatchMessage
sPrompt = sPrompt + vbCrLf + vbCrLf + "Enter blank to cancel"
sGet = InputBox(sPrompt, "Please select one")
If Trim(sGet) = "" Then Exit Sub
sPrompt = "Value must be a number" + vbCrLf + vbCrLf + sPrompt
Do While IsNumeric(sGet) = False
sGet = InputBox(sPrompt, "Please select one")
If Trim(sGet) = "" Then Exit Sub
Loop
iMatch = CInt(sGet)
Application.ActiveWorkbook.Sheets(iMatch).Activate
End Select
End Sub
I hope someone finds this useful, and would also welcome enhancement suggestions.
For fun tried to do this in as few lines as possible with loops
Uses a range name, xlm, and VBS under utilised Filter to provide the same multi-sheet search functionality as above.
The bulk of the code relates to the sheet selection portion
Sub GetNAmes()
Dim strIn As String
Dim X
strIn = Application.InputBox("Search string", "Enter string to find", ActiveSheet.Name, , , , , 2)
If strIn = "False" Then Exit Sub
ActiveWorkbook.Names.Add "shtNames", "=RIGHT(GET.WORKBOOK(1),LEN(GET.WORKBOOK(1))-FIND(""]"",GET.WORKBOOK(1)))"
X = Filter([index(shtNames,)], strIn, True, 1)
Select Case UBound(X)
Case Is > 0
strIn = Application.InputBox(Join(X, Chr(10)), "Multiple matches found - type position to select", , , , , 1)
If strIn = "False" Then Exit Sub
On Error Resume Next
Sheets(CStr(X(strIn))).Activate
On Error GoTo 0
Case 0
Sheets(X(0)).Activate
Case Else
MsgBox "No match"
End Select
End Sub
Related
I was trying to create a universal, error resistant VBA code that would count words in selected ranges as MS Word does. This below is the best I could do and I was hoping that somebody would have a look and let me know if I missed something or suggest any improvements. The code is quite fast and works with single cell, non-adjacent cells and whole columns, I need it to be as universal as possible. I'll be looking forward to feedback.
Option Explicit
Sub word_count()
Dim r() As Variant 'array
Dim c As Long 'total counter
Dim i As Long
Dim l As Long 'string lenght
Dim c_ch As Long 'character counter
Dim c_s As String 'string variable
Dim cell As range
Dim rng As range
If Selection Is Nothing Then
MsgBox "Sorry, you need to select a cell/range first", vbCritical
Exit Sub
ElseIf InStr(1, Selection.Address, ":", vbTextCompare) = 0 And InStr(1, Selection.Address, ",", vbTextCompare) = 0 Then 'for when only one cell is selected
word_count_f Selection.Value, c
MsgBox "Your selected cell '" & Replace(Selection.Address, "$", "") & "' in '" & Selection.Parent.Name & "' has " & c & " words."
Exit Sub
ElseIf InStr(1, Selection.Address, ",", vbTextCompare) > 0 Then 'when user selects more than one cell by clicking one by one -> address looks like ('A1,A2,A3') etc
Application.ScreenUpdating = False
Dim help() As Variant
ReDim help(1 To Selection.Cells.Count)
i = 1
For Each cell In Selection 'loading straigh to array wouldn't work, so I create a helper array
help(i) = cell.Value
i = i + 1
Next cell
r = help
Else 'load selection to array to improve speed
Application.ScreenUpdating = False
r = Selection.Value
End If
Dim item As Variant
For Each item In r
word_count_f item, c
Next item
MsgBox "Your selected range '" & Replace(Selection.Address, "$", "") & "' in '" & Selection.Parent.Name & "' has " & c & " words."
End Sub
Private Function word_count_f(ByVal item As Variant, ByRef c As Long)
Dim l As Long 'lenght variable
Dim c_s As String 'whole string variable
Dim c_ch As Long 'characted count variable
l = Len(item)
If l = 0 Then Exit Function
c_s = item
c_s = Trim(c_s)
Do While InStr(1, c_s, " ", vbTextCompare) > 0 'remove double spaces to improve accuracy
c_s = Replace(c_s, " ", " ")
Loop
If InStr(1, c_s, " ", vbTextCompare) = 0 And l > 0 Then 'if there was just one word in the cell
c = c + 1
ElseIf InStr(1, c_s, " ", vbTextCompare) > 0 Then 'else loop through string to count words
For c_ch = 1 To l 'loop through charactes of the string
If (Mid(c_s, c_ch, 1)) = " " Then
c = c + 1 'for each word
End If
Next c_ch
c = c + 1 'add one for the first word in cell
Else 'hopefully useless msgbox, but I wanted to be sure to inform the user correctly
MsgBox "Sorry, there was an error while processing one of the cells, the result might not be accurate", vbCritical
End If
End Function
You can achieve this in a similar way but with less code if you are interested to see?:
Sub word_count()
start_time = Timer
Dim r As Variant 'temp split array
Dim arr As Variant 'array
Dim c As Long 'total counter
If Selection Is Nothing Then
MsgBox "Sorry, you need to select a cell/range first", vbCritical
Exit Sub
Else
c = 0
For Each partial_selection In Split(Selection.Address, ",")
If Range(partial_selection).Cells.Count > 1 Then
arr = Range(partial_selection).Value
Else
Set arr = Range(partial_selection)
'single cell selected don't convert to array
End If
For Each temp_cell In arr
If Len(Trim(temp_cell)) > 0 Then
r = Split(temp_cell, " ")
For Each temp_word In r
If Len(Trim(temp_word)) > 0 Then
c = c + 1
'If the word is just a blank space don't count
End If
Next
'c = c + (UBound(r) - LBound(r) + 1)
'trimmed = Trim(temp_cell)
'c = c + 1 + (Len(trimmed) - Len(Replace(trimmed, " ", "")))
Else 'Blank cell
'Do nothing
End If
Next
Next
End If
Dim item As Variant
time_taken = Round(Timer - start_time, 3)
MsgBox "Your selected range '" & Replace(Selection.Address, "$", "") _
& "' in '" & Selection.Parent.Name & "' has " & c & " words." _
& vbNewLine & "Time Taken: " & time_taken & " secs"
Debug.Print c & " in "; time_taken; " secs"
End Sub
You could try this sort of approach? There may be the need to check for the next character to the space being another space, which would need some additions made. To detect word one as being the same as word one in the count. Also, transferring the range to an array would make it a touch faster.
Function Word_Count(rng As Excel.Range) As Long
Dim c As Excel.Range
Dim s As String
Dim l As Long
For Each c In rng.Cells
s = Trim(c.Value)
If s <> "" Then
If InStr(1, s, " ") > 0 Then
' Find number of spaces. You can use the ubound of split maybe here instead
l = l + (Len(s) - Len(Replace(s, " ", "")))
Else
End If
' Will always be 1 word
l = l + 1
End If
Next c
Word_Count = l
Set c = Nothing
End Function
I've written the below code to search for a value(Supplier Name) in sheet "Fusion" Column H in sheet "CX" column D. I'm also doing a check the other way around so if the same value(Supplier Name) in sheet CX is in sheet "Fusion". I'm not looking for an Exact match hence the use of Instr and doing the comparison both ways as i'm not sure how a user has entered the information in either sheet.
The data type in either cell should be text.
If a match is found then in the last column of sheet "CX" it should just populate either "Supplier Found" or "Supplier Not Found"
Currently it's not populating the last column with any data but the Macro isn't erroring at any point.
I've tried adding msgboxes and "Here" and "Here3" are being triggered but it doesn't seem to be hitting the section of code that is "Here2" so I think it's there that's causing the issue but not sure how to resolve it.
Screenshot of my Data is :CX Sheet
Fusion Sheet
Any help would be greatly appreciated.
Option Explicit
Sub CompareCXFusion()
Dim CX As Worksheet
Dim Fusion As Worksheet
Dim strTemp as string
Dim strCheck as string
Dim i As Long, J As Long
Dim CXArr As Variant
Dim FusionArr As Variant
Dim match As Boolean
Dim CXRng As Range
Dim FusionRng As Range
Set CX = ActiveWorkbook.Sheets("CX")
Set Fusion = ActiveWorkbook.Sheets("Fusion")
Set CXRng = CX.Range("A2", CX.Cells(Rows.Count, "A").End(xlUp).Offset(0, 6))
Set FusionRng = Fusion.Range("A2", Fusion.Cells(Rows.Count, "A").End(xlUp).Offset(0, 9))
CXArr = CXRng.Value2
FusionArr = FusionRng.Value2
strTemp = lcase(trim(FusionArr(J, 7)))
strCheck = lcase(trim(CXArr(i, 3)))
For i = 1 To UBound(CXArr)
Match = False
For J = 1 To UBound(FusionArr)
MsgBox "Here"
If (Instr(strTemp, strCheck) > 0) OR (InStr(strCheck, strTemp) > 0) Then
MsgBox"Here2"
CXArr(i, 6) = "Supplier Found"
Else
Msgbox"Here3"
CXArr(i, 6) = "Supplier not found"
End If
Next J
Next i
End Sub
The expected output i'd expect is: If in Column H of Fusion the Supplier Name is "Supplier A" and the value in Column D of sheet "CX" is "Supplier A LTD" then i'd expect it to populate column G in sheet CX with "Supplier Found" due to it being found in the string.
If you need any more info please let me know.
I don't know how to correctly insert examples of my data else I would have
Option Explicit
Sub CompareCXFusion()
Dim CX As Worksheet
Dim Fusion As Worksheet
Dim i As Long, J As Long, lastRowCX As Long, lastRowFU As Long
Dim CXText As String, FusionText As String
Dim match As Boolean
Dim CXRng As Range, FusionRng As Range
Set CX = ActiveWorkbook.Sheets("CX")
Set Fusion = ActiveWorkbook.Sheets("Fusion")
lastRowCX = CX.Range("D1").SpecialCells(xlCellTypeLastCell).Row - 1
lastRowFU = Fusion.Range("H1").SpecialCells(xlCellTypeLastCell).Row - 1
Set CXRng = CX.Range("D1:D" & lastRowCX)
Set FusionRng = Fusion.Range("H1:H" & lastRowFU)
For i = 1 To lastRowCX
match = False
For J = 1 To lastRowFU
'Debug.Print "Here"
FusionText = FusionRng.Range("A1").Offset(J, 0).Value
CXText = CXRng.Range("A1").Offset(i, 0).Value
If FusionText <> "" And CXText <> "" Then
If InStr(FusionText, CXText) Or InStr(CXText, FusionText) Then
'Debug.Print "Here2"
match = True
End If
End If
Next J
'Result goes to column G of CX range:
If match Then
CXRng.Range("A1").Offset(i, 3).Value = "Supplier found" ' "Supplier found - " & i & " - " & CXRng.Range("A1").Offset(i, 0).Address & " - " & CXRng.Range("A1").Offset(i, 3).Address
Else
CXRng.Range("A1").Offset(i, 3).Value = "Supplier NOT found" '"Supplier NOT found - " & i & " - " & CXRng.Range("A1").Offset(i, 0).Address & " - " & CXRng.Range("A1").Offset(i, 3).Address
End If
Next i
End Sub
You need to make sure to check for case sensitivity:
Dim strTemp as string
Dim strCheck as string
'Inside for I loop
'Inside for j Loop
strTemp = lcase(trim(FusionArr(J, 7)))
strCheck = lcase(trim(CXArr(i, 3)))
If (Instr(strTemp, strCheck) > 0) OR (InStr(strCheck, strTemp) > 0) Then
'...
End If
'end for j
'end for i
I have a Userform with a listbox for which I am using conditional logic to determine output values to the sheet of selected or non-selected items in the listbox. The issue is that when the Textbox (Tbl_AliasName) is blank, the code executes this:
ElseIf .Selected(k) = True And Tbl_AliasName = vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Trim(Cells(2, 1).Value2) & "." & .Column(1, k)
But if Tbl_AliasName is not blank then the code does nothing, but it is supposed to do this:
ElseIf .Selected(k) = True And Tbl_AliasName <> vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Tbl_AliasName & "." & .Column(1, k)
I have used several variations of If statements, and non of which have worked.
Below is My Code:
Option Explicit
Public Tbl_AliasName As String
Tbl_AliasName = Trim(UserForm_Finder.txtConcat.Value)
Private Sub BtnConcat_Click()
Dim k As Long, lstbxRow As Long, LR As Long
lstbxRow = 1
'****************
'This if statement works perfectly
If (Cells(2, 1).Value2 = vbNullString Or Cells(2, 2).Value2 = vbNullString) _
And Tbl_AliasName = vbNullString Then
MsgBox "You must Search for a Table or Column first.", _
vbExclamation, "Error Encountered"
Exit Sub
ElseIf (UserForm_Finder.ListBx_TblsCols.ListCount = 0 And Tbl_AliasName <> vbNullString) Then
MsgBox "You must Search for a Table or Column first.", _
vbExclamation, "Error Encountered"
'(Cells(2, 1).Value2 = vbNullString Or Cells(2, 2).Value2 = vbNullString) And _
Exit Sub
End If
With UserForm_Finder.ListBx_TblsCols
For k = 0 To .ListCount - 1
'****************
This is where the problems begin
If .Selected(k) = False Then
MsgBox "You must Select 1 or more items from the list box.", _
vbExclamation, "Error Encountered"
Exit Sub
ElseIf .Selected(k) = True And Tbl_AliasName <> vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Tbl_AliasName & "." & .Column(1, k)
ElseIf .Selected(k) = True And Tbl_AliasName = vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Trim(Cells(2, 1).Value2) & "." & .Column(1, k)
End If
Next k
End With
End Sub
My goal is to do the following:
If a Textbox (Tbl_AliasName) is not blank and the user has selected one or more items in the listbox (ListBx_TbleCols) then concatenate the Tbl_AliasName to the selected items in the listbox
If Tbl_AliasName is blank, then use the value in Cells(2,1) to concatenate to the selected Items in the list box.
I have tried the following additions:
Dim LstBxItemSelected As Boolean
'This was placed in the for loop
LstBxItemSelected = True
'this was placed outside the for loop
If LstBxItemSelected = False Then
MsgBox "You must Select 1 or more items from the list box.", _
vbExclamation, "Error Encountered"
Exit Sub
End If
Is there a better way to tell if items are selected, because I feel that the way I have it structured in my loop, the code will throw the error if everything isn't selected? Thank you in advance for any ideas, answers, or suggestions!
Note: The Listbox is populated by the click of another button on the userform which calls the following sub:
Sub FillLstBxCols()
Dim ListBx_Target As MSForms.ListBox
Dim rngSource As Range
Dim LR As Long
If Cells(2, 1).Value2 <> vbNullString Then
LR = Worksheets("New TRAX").Cells(Rows.Count, 2).End(xlUp).Row
'Set reference to the range of data to be filled
Set rngSource = Worksheets("New Trax").Range("A" & 2 & ":" & "B" & LR)
'Fill the listbox
Set ListBx_Target = UserForm_Finder.ListBx_TblsCols
With ListBx_Target
.RowSource = rngSource.Address
End With
End If
End Sub
Hard to say without sample data and expected results, but I think this is what you're looking for:
Private Sub btnConcat_Click()
Dim ws As Worksheet
Dim bSelected As Boolean
Dim sConcat As String
Dim i As Long, lRowIndex As Long
Set ws = ActiveWorkbook.Sheets("New TRAX")
lRowIndex = 1
bSelected = False
sConcat = Trim(Me.txtConcat.Text)
If Len(sConcat) = 0 Then sConcat = Trim(ws.Cells(2, "A").Value)
If Len(sConcat) = 0 Then
MsgBox "You must Search for a Table or Column first.", vbExclamation, "Error Encountered"
Exit Sub
End If
For i = 0 To Me.ListBx_TblsCols.ListCount - 1
If Me.ListBx_TblsCols.Selected(i) Then
If bSelected = False Then
bSelected = True
ws.Range("C2", ws.Cells(ws.Rows.Count, "C")).Clear 'clear previous concat results (delete this line if not needed)
End If
lRowIndex = lRowIndex + 1
ws.Cells(lRowIndex, "C").Value = sConcat & "." & Me.ListBx_TblsCols.List(i)
End If
Next i
If bSelected = False Then MsgBox "Must select at least one item from the list"
End Sub
I want to trim a string in MS Excel each cell to 100 characters in a column with 500 cells.
Starting with first cell, check if string length is or equal 100 characters. If the words are more than 100, then remove 1 word in the cell, then check again, if it's more than 100 remove another word until the string is less to 100. Then paste the less than 100 character string into the same cell replacing previous more than 100 character string.
Then move to another cell and replete the previous step.
The words to be removed are in an array
Here is my code so far
Sub RemoveWords()
Dim i As Long
Dim cellValue As String
Dim stringLenth As Long
Dim myString As String
Dim words() As Variant
words = Array("Many", "specific ", "Huawei", "tend", "Motorolla", "Apple")
myString = "Biggest problem with many phone reviews from non-tech specific publications is that its reviewers tend to judge the phones in a vacuum"
For i = 1 To 13
cellValue = Cells(i, 4).Value
If Not IsEmpty(cellValue) Then
stringLength = Len(cellValue)
' test if string is less than 100
If stringLength > 100 Then
Call replaceWords(cellValue, stringLength, words)
Else
' MsgBox "less than 100 "
End If
End If
Next i
End Sub
Public Sub replaceWords(cellValue, stringLength, words)
Dim wordToRemove As Variant
Dim i As Long
Dim endString As String
Dim cellPosition As Variant
i = 0
If stringLength > 100 Then
For Each wordToRemove In words
If InStr(1, UCase(cellValue), UCase(wordToRemove )) = 1 Then
MsgBox "worked word found" & " -- " & cellValue & " -- " & key
Else
Debug.Print "Nothing worked" & " -- " & cellValue & " -- " & key
End If
Next wordToRemove
Else
MsgBox "less than 100 "
End If
End Sub
Sub NonKeyWords()
' remove non key words
'
Dim i As Long
Dim cellValue As String
Dim stringLenth As Long
Dim wordToRemove As Variant
Dim words() As Variant
Dim item As Variant
' assign non-key words to array
words = words = Array("Many", "specific ", "Huawei", "tend", "Motorolla", "Apple")
' loop though all cells in column D
For i = 2 To 2000
cellValue = Cells(i, 4).Value
If Not IsEmpty(cellValue) Then
' test if string is less than 100
If Len(cellValue) > 100 Then
'Debug.Print "BEFORE REMOVING: " & cellValue
Call replaceWords(cellValue, words, i)
Else
' MsgBox "less than 100"
End If
End If
Next i
End Sub
Public Sub replaceWords(cellValue, words, i)
If Len(cellValue) > 100 Then
For Each wordsToDelete In words
If Len(cellValue) > 100 Then
cellValue = Replace(cellValue, wordsToDelete, "")
'Debug.Print cellValue
Debug.Print "String length after removal = " & Len(cellValue)
Debug.Print "remove another word................"
'cells(i, 4).ClearContents
Cells(i, 4).Value = cellValue
Else
'exit
End If
Next
Else
Debug.Print "SAVE: " & cellValue
End If
End Sub
I have a drop-down list in my sheet. When I make a selection, is it possible to get the items before and after the selected item in the list?
Example:
In the above list-
If the user selects "Kylo", I want to get "Han" and "Leia".
If "Luke" is selected, I want to get "Leia".
And if "Darth" is selected, I want to get "Han".
Is this possible?
Cheers,
VJ
The question does not have enough details for a good answer, but from what I understand you have the list of values in the range #DataSheet!A2:A51 and the selected item in cell A1 so something like:
Dim r As Range, c As Range
Set r = [#DataSheet!A2:A51]
Set c = r.Find([A1])
If Not c Is Nothing Then
If c.Row > r.Row Then MsgBox "Before: " & c(0)
If c.Row < r.Row + r.Rows.Count Then MsgBox "After: " & c(2)
End If
This will do it:
' rename "Combobox1" to the name of your control below
Private Sub ComboBox1_Change()
Dim idx As Long
With ComboBox1
idx = .ListIndex
If idx = 0 Then
MsgBox "Next item: " & .List(idx + 1, 0)
ElseIf idx = .ListCount - 1 Then
MsgBox "Previous item: " & .List(idx - 1, 0)
Else
MsgBox "Previous item: " & .List(idx - 1, 0) & Chr(13) & "Next item: " & .List(idx + 1, 0)
End If
End With
End Sub
I ended up importing the range into an array and then find the items before and after. Simple code below. Any inputs are welcome. Thanks heaps!
Sub GetItemBeforeAfter ()
Dim aArray As Variant
Dim sItem As String
Dim iCounter As Integer
Dim iPosition As Integer
Dim sItemBefore As String
Dim sItemAfter As String
aArray = ActiveWorkbook.Sheets("#DataSheet").Range("A2:A51").Value
sItem = "Death Star"
With Application
For iCounter = LBound(aArray, 1) To UBound(aArray, 1)
iPosition = .Match(sItem, .Index(aArray, 0, iCounter), 0)
If IsNumeric(iPosition) Then
Select Case iPosition
Case LBound(aArray, 1)
sItemAfter = aArray(iPosition + 1, 1)
MsgBox "No Before!"
MsgBox "After: " & sItemAfter
Case UBound(aArray, 1)
sItemBefore = aArray(iPosition - 1, 1)
MsgBox "Before: " & sItemBefore
MsgBox "No After!"
Case Else
sItemBefore = aArray(iPosition - 1, 1)
sItemAfter = aArray(iPosition + 1, 1)
MsgBox "Before: " & sItemBefore
MsgBox "After: " & sItemAfter
End Select
Exit For
Else
MsgBox "Item Not Found"
End If
Next
End With
End Sub