I have a code I use to concatenate highlighted cells with a separating " OR " between them. It places the data into a text box. My problem is that it adds a final " OR " to the end of the text string. I would like the text to automatically get rid of the last " OR " or to not put it in at all.
Dim rCell As Range, strJoin As String
Dim box As TextBox
Set box = ActiveSheet.TextBoxes.Add(ActiveCell.Offset(1, 1).Left, _
ActiveCell.Offset(1, 1).Top, ActiveCell.Offset(1, 3).Left, _
ActiveCell.Offset(6, 1).Top)
With box
.Text = vbNullString
For Each rCell In Selection
strJoin = rCell
box.Text = box.Text & strJoin & " OR "
Next rCell
End With
End Sub
I have a series of these that I use to create SQL queries, and not having to manually remove the last word would be lovely.
Thank you in advance for any help you are able to provide.
I like this pattern:
Dim sep as string
For Each rCell In Selection
box.Text = box.Text & sep & rCell.Value
sep = " OR "
Next rCell
Related
I need to be able to "show my working" in excel. So when I print the sheet for clients all the work can be checked without having the original spreadsheet. I'm sort of trying to replicate the "Evaluate Formula" feature of excel, but within the cell. I can do it manually, but it's really time consuming as I have a lot of formula.
So if I have this in a cell
=(C2*C3)+C4
I want to be able to use VBA magic to turn it into this
="("&TEXT(C2,"0.00")&" x "&TEXT(C3,"0.00")&" ) + "&TEXT(C4,"0.00")
so the result looks like this
(50.22 x 2.11 ) + 3.22
I can convert the math's signs (brackets, multiply, etc) in VBA. But I don't know how to recognize the cell references, so that I can do the text conversion part (I can't leave the formula without the text function - the decimal places are too long). Any help would be greatly appreciated.
This will reformat the selected cells and put the result in the cell 1 column to the right.
Sub ReformatForumla()
Dim prec As Range
Dim rng As Range
Dim frm As String
Dim cellRef As String
Dim loopRng As Range
Dim i As Long
Dim stored() As Variant
Dim sorted As Variant
For Each loopRng In Selection
frm = Replace(loopRng.Formula, "$", "")
frm = "=""" & frm & """"
Set prec = loopRng.Precedents
i = 1
ReDim stored(prec.Cells.Count, 2)
For Each rng In prec
stored(i, 1) = rng.Address
stored(i, 2) = Len(rng.Address)
i = i + 1
Next rng
sorted = Application.WorksheetFunction.Sort(stored, 2, -1)
For i = 1 To prec.Cells.Count
cellRef = Replace(sorted(i, 2), "$", "")
frm = Replace(frm, cellRef, """ & TEXT(" & Application.ConvertFormula(cellRef, xlA1, xlA1, xlAbsolute) & ",""0.00"") & """)
Next i
frm = Replace(frm, "+", " + ")
frm = Replace(frm, "-", " - ")
frm = Replace(frm, "*", " x ")
frm = Replace(frm, "/", " / ")
loopRng.Offset(0, 1).Value = frm
Next loopRng
End Sub
I've done quite a bit of searching around for this one...and I'm not getting anywhere.
I have a spreadsheet(specific column) with values such as:
42153-95
54126-3
13613-6331
16136-336
My goal is to add zero's after the - and before the existing #'s(to 4 places). Like:
42153-0095
54126-0003
13613-6331
16136-0336
I've tried a a lot of different options within the quotes of NumberFormat:
Worksheets("Sheet1").Columns("C"). _ NumberFormat = "00000-0000"
No luck so far. :(
Any help would be greatly appreciated.
Thanks!
Sub testFunc()
MsgBox addZero("54126-3")
End Sub
'/ Function to add Zeros
Public Function addZero(strVal As String) As String
Dim arrTemp
Dim strTemp
arrTemp = Split(strVal, "-")
strTemp = arrTemp(0) & "-" & String(4 - Len(arrTemp(1)), "0") & arrTemp(1)
addZero = strTemp
End Function
As #tigeravatar stated it can be done with a formula. With the Evaluate function we can use an array form of the formula he gave in his comment.
You can apply this to your values in column C:
Worksheets("Sheet1").Range("C1:C4").Value = Worksheets("Sheet1").Evaluate("=INDEX(LEFT(C1:C4,6) & TEXT(--MID(C1:C4,7,LEN(C1:C4)),""0000""),)")
If your range is dynamic and you have the final row in a variable like lstrow you can replace all the C4 with C" & lstrow & "
Worksheets("Sheet1").Range("C1:C" & lstrow).Value = Worksheets("Sheet1").Evaluate("=INDEX(LEFT(C1:C" & lstrow & ",6) & TEXT(--MID(C1:C" & lstrow & ",7,LEN(C1:C" & lstrow & ")),""0000""),)")
Select the cells you wish to process and run:
Sub dural()
Dim r As Range
bry = Array("0000", "000", "00", "0", "")
For Each r In Selection
ary = Split(r.Value, "-")
ary(1) = bry(Len(ary(1))) & ary(1)
r.Value = Join(ary, "-")
Next r
End Sub
Before:
and after:
I'm trying to find an exact word from a sentence by excel VBA with below code.
Dim col As Range, cell1 As Range, a As String, i As Integer
Set col = Range("KW[KW1]")
Dim target, cell As Range
Sheets("Data").Select
Set target = Range(Range("B1"), Range("B65536").End(xlUp))
Dim term, tag As String
For Each cell1 In col
a = cell1.Value
term = a
tag = a
For Each cell In target
If InStr(1, cell, term, 1) Then
For i = 1 To 50
If cell.Offset(0, i).Value = "" Then
cell.Offset(0, i).Value = tag
GoTo Step1
End If
Next i
End If
Step1:
Next cell
Next cell1
End Sub
But its giving result for "wood" from "Rosewood" which is wrong. How to find only exact word "wood"
Easiest way to do exact word searches is to surround the search text and the word you're looking for with spaces. Using your code it would like this:
If InStr(1, " " & cell & " ", " " & term & " ", 1) Then
That way it won't find "wood" within "Rosewood"
My issue is that I am trying to extract some information from a very large data sheet. The information that is being extracted is based on some search criteria that is entered on a form. The search form counts how many occurrences of this criteria exist, but then I need to extract the individual rows into a second sheet.
The bit I'm having difficulty with is understanding how to actually structure the extraction code. I'm in need of being pointed in the right direction. If the code can count how many occurrences there are, surely I can get the row numbers for those occurrences and extract the information, I'm just not getting anywhere trying to figure it out.
Here's my SEARCH code (this code works to get the number of occurrences based on the criteria asked)
Public Sub Run_Count_Click()
'// Set Ranges
Dim Cr_1, CR1_range, _
Cr_2, CR2_range, _
Cr_3, CR3_range, _
Cr_4, CR4_range, _
Cr_5, CR5_range _
As Range
'// Set Integers
Dim CR1, V1, CR1_Result, _
CR2, V2, CR2_Result, _
CR3, V3, CR3_Result, _
CR4, V4, CR4_Result, _
CR5, V5, CR5_Result, _
total_result, _
total_result2, _
total_result3, _
total_result4, _
total_result5 _
As Integer
'Set Strings
Dim V_1, V_2, V_3, V_4, V_5 As String
Dim ws As Worksheet
Set ws = Worksheets("database")
Sheets("Settings").Range("Start_Date").Value = Format(Me.R_Start.Value, "mm/dd/yyyy")
Sheets("Settings").Range("End_Date").Value = Format(Me.R_End.Value, "mm/dd/yyyy")
'Collect Start & End Dates
Dim dStartDate As Long
Dim dEndDate As Long
dStartDate = Sheets("Settings").Range("Start_Date").Value
dEndDate = Sheets("Settings").Range("End_Date").Value
ws.Activate
On Error GoTo error_Sdate:
Dim RowNum As Variant
RowNum = Application.WorksheetFunction.Match(dStartDate, Range("B1:B60000"), 0)
'MsgBox "Found " & Format(dStartDate, "dd/mm/yyyy") & " at row : " & RowNum
On Error GoTo error_Edate:
Dim RowNumEnd As Variant
RowNumEnd = Application.WorksheetFunction.Match(dEndDate, Range("B1:B60000"), 1)
' MsgBox "Found " & Format(dEndDate, "dd/mm/yyyy") & " at row : " & RowNumEnd
GoTo J1
error_Sdate:
Dim msg As String
msg = "You entered " & Format(dStartDate, "dd/mm/yyyy") & " as your Start Date, but no referrals were made on that date"
msg = msg & vbCrLf & "Please enter a different date in the Start Date box"
MsgBox msg, , "Start Date Not Found"
Err.Clear
Exit Sub
error_Edate:
msg = "You entered " & Format(dEndDate, "dd/mm/yyyy") & " as your End Date, but no referrals were made on that date"
msg = msg & vbCrLf & "Please enter a different date in the End Date box"
MsgBox msg, , "End Date Not Found"
Err.Clear
Exit Sub
J1:
'// Get Criteria From Form And Search Database Headers
Set Cr_1 = ws.Cells.Find(What:=Me.Count_Criteria_1.Value, After:=ws.Cells(1, 1), MatchCase:=False)
If Not Cr_1 Is Nothing Then
CR1 = Cr_1.Column '//Set CR1 as the Column in which the Criteria Header was found
Else
MsgBox "Criteria 1 Has Not Been Found In The Database. Report Has Failed To Generate"
Exit Sub
End If
'// Get Variable Value From Form And Set Shortcode
V_1 = Me.Criteria_1_Variable.Value
Set CR1_range = ws.Range(ws.Cells(RowNum, CR1), ws.Cells(RowNumEnd, CR1))
CR1_Result = Application.CountIf(CR1_range, V_1)
Me.Count_Result.visible = True
Me.Count_Result.Value = "Based On Your Search Criteria Of:" & vbNewLine & vbNewLine & _
"- " & Me.Count_Criteria_1.Value & ": " & Me.Criteria_1_Variable.Value & vbNewLine & vbNewLine & _
"The Results Are: " & CR1_Result & " entries found between the dates " & Format(dStartDate, "dd/mm/yyyy") & _
" and " & Format(dEndDate, "dd/mm/yyyy")
Exit Sub
Is there an easy way of doing this with a loop? I know loops are not the best way of handling things, but Im looking for anything that works and I can tweak to suit my needs.
Thanks if you can help in advance, it's a monster of a spreadsheet!
----------------------------
*Update With Accepted Answer:*
----------------------------
Public Sub Count_Extract_Click()
'Collect Information To Be Extracted
Set ws = Worksheets("database")
Set ps = Worksheets("Extracted Rows")
ps.Range("A3:AM60000").Clear
For i = RowNum To RowNumEnd
If ws.Cells(i, CR1).Value = V_1 Then
ws.Range("A" & i & ":AM" & i).Copy
ps.Activate
'find first empty row in database
emR = ps.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
ps.Range("A" & emR & ":AM" & emR).PasteSpecial
End If
Next i
End If
End Sub
You should be able to set a For loop to check each value in the range you've found and copy it to (another cell, an array, whatever you like.)
For i = rowNum To rowNumEnd
If Cells(i,CR1).Value = V_1 Then
MsgBox "Found match on row " & i
End If
Next i
I haven't tested this, but it should work. Let me know if you get any errors.
I can't really try this out, but maybe you can. Keep the line V_1 = Me.Criteria_1_Variable.Value but replace the next 2 by :
CR1_Result = 0 'Initiates counter at 0
Dim CR1_Lines(1000) As Long 'Declares an array of 1001 (indexes 0-1000) Longs (big integers)
For x = RowNum To RowNumEnd 'Loops through all the rows of CR1
If ws.Cells(x, CR1) = V_1 Then 'Match!
'Double array size if capacity is reached
If CR1_Result = UBound(CR1_Lines) Then
ReDim Presrve CR1_Lines(UBound(CR1_Lines) * 2)
End If
'Store that line number in the array
CR1_Lines(CR1_Result) = x
'Increment count of matches
CR1_Result = CR1_Result + 1
End If
Next x 'Next row!
You can then loop through that array with this code :
For i = 0 to UBound(CR1_Lines)
'Do something! (Why not just an annoying pop-up box with the content!)
MsgBox CR1_Lines(i)
Next i
EDIT : I just read that the spreadsheet is monstruous, and re-dimensioning every time a new match is found might be neat, but it's a hell of a performance drop. I made some changes directly in the above code to make it somewhat more effective.
EDIT #2 : I've simplified code so you don't have anything to do but a copy paste (please forgive me not assuming RowNum and RowNumEnd had valid data). It should work exactly as accepted answer, but was posted a bit before and actually shows how to extract the line number. I understand if all you needed is a pop-up box with the line number, and will be satisfied with the upvote already received.
. I have an excel spreadsheet which contains some strings with unicode control characters that aren't visible in Windows 7. Therefore, I would like to write a macro to iterate through each cell in a column, checking if a control character is present. If a control character is found, I would like to populate the adjacent cell in the next column with the character name and the index it can be found within the string.
This is what I have so far:
Sub control_chr()
'
' control_chr Macro
'
'
Dim control_characters(Chr(28), Chr(29), Chr(30), Chr(31), Chr(32))
Dim r As Range, cell As Range
Set r = Range("F4:F1029")
For Each cell In r
For Each Character In control_characters
the next step would be to search the cell for each character and populate adjacent cells with the results. My first thought was to use the SEARCH() function since it returns the index of where the character is found. This is my first time using visual basic and I'm not sure how to proceed
Here's some code that does what you asked:
Sub ListControlChars()
Dim control_characters As Variant
Dim r As Range, cell As Range, ResultCell As Range
Dim CharPosition As Long
Dim i As Long
control_characters = Array(28, 29, 30, 31, 32)
Set r = ActiveSheet.Range("F4:F1029")
For Each cell In r
Set ResultCell = cell.Offset(0, 1)
ResultCell.ClearContents
CharPosition = 0
For i = LBound(control_characters) To UBound(control_characters)
CharPosition = InStr(cell, Chr(control_characters(i)))
If CharPosition > 0 Then
ResultCell = ResultCell.Value & "Char " & control_characters(i) & ": Position " & CharPosition & " - "
End If
Next i
Next cell
End Sub
If you want to do it in Excel you could set it up like this:
The formula in B2 is:
=IFERROR(SEARCH(CHAR(B$1),$A2),"")
I can't recall if I coded this up or found it somewhere else, but this works for me when encountering issues with loading data into certain databases which fail on unrecognised special characters
Function IterateThruCells()
Dim cell As Range
For Each cell In ActiveSheet.UsedRange.Cells
If cell.Value <> "" Then
If ContainsSpecialCharacters(cell.Value) = True Then
Debug.Print cell.Address & ": " & cell.Value
End If
End If
Next
End Function
Function ContainsSpecialCharacters(str As String) As Boolean
Dim I
For I = 1 To Len(str)
ch = Mid(str, I, 1)
Select Case ch
Case "0" To "9", "A" To "Z", "a" To "z", " ", "(", ")", "/", "-", ".", ",", "_", "&", "'", "$", ">", "<", "–"
ContainsSpecialCharacters = False
Case Else
ContainsSpecialCharacters = True
Exit For
End Select
Next
End Function