I am using a user form to display the acronyms found in a document and the definitions of the acronyms. Because i won't know in advance how many there will be I have created all of the labels, check boxes and comboBoxes dynamically using the for loop below.
I am now stuck in that I want to allow the user to be able to type in the comboBox a new definition is for example one didn't exist in my excel database or they want to use a different definition to the one that is there (I am aware this is bad practice but unfortunately people don't stick to the standard list). Now that all works fine with it set up as it is however my problem is that I want to check if the user has entered something new or not.
So my question is, is there a built in function or variable that does this? or is there a simple way to do it? (I already have tried and tested the code to add the string to my database so that is not an issue, just the checking if it wasn't there before without running through the entire database from scratch again)
For i = 1 To n
checkBoxi = "CheckBox" & i
labeli = "Label" & i
comboBoxi = "ComboBox" & i
'add checkbox, label and combobox
.MultiPage1.Pages("Page1").Controls.Add "Forms.CheckBox.1", checkBoxi
.MultiPage1.Pages("Page1").Controls.Add "Forms.Label.1", labeli
.MultiPage1.Pages("Page1").Controls.Add "Forms.ComboBox.1", comboBoxi
'position check box
.MultiPage1.Pages("Page1").Controls(checkBoxi).Left = LeftSpacing
.MultiPage1.Pages("Page1").Controls(checkBoxi).Top = TopSpacing + rowHeight * i
'position labels
.MultiPage1.Pages("Page1").Controls(labeli).Left = LeftSpacing + 15
.MultiPage1.Pages("Page1").Controls(labeli).Top = TopSpacing + 2 + rowHeight * i
.MultiPage1.Pages("Page1").Controls(labeli).Caption = acronyms(i - 1)
.MultiPage1.Pages("Page1").Controls(labeli).Width = 70
'position comboBox
.MultiPage1.Pages("Page1").Controls(comboBoxi).Left = LeftSpacing + 100
.MultiPage1.Pages("Page1").Controls(comboBoxi).Top = TopSpacing + rowHeight * i
.MultiPage1.Pages("Page1").Controls(comboBoxi).Width = 300
'find definitions for comboBox
' Find the definition from the Excel document
With objWbk.Sheets("Sheet1")
' Find the range of the cells with data in Excel doc
Set rngSearch = .Range(.Range("A1"), .Range("A" & .rows.Count).End(-4162))
' Search in the found range for the
Set rngFound = rngSearch.Find(What:=acronyms(i - 1), After:=.Range("A1"), LookAt:=1)
' if nothing is found count the number of acronyms without definitions
If rngFound Is Nothing Then
' Set the cell variable in the new table as blank
ReDim targetCellValue(0) As String
targetCellValue(0) = ""
' If a definition is found enter it into the cell variable
Else
targetCellValue(0) = .Cells(rngFound.Row, 2).Value
'MsgBox (targetCellValue(0) & " " & 0)
firstAddress = rngFound.Address
Do Until rngFound Is Nothing
Set rngFound = rngSearch.FindNext(After:=rngFound)
If rngFound.Address = firstAddress Then
Exit Do
ElseIf rngFound.Address <> firstAddress Then
j = j + 1
ReDim Preserve targetCellValue(0 To j) As String
targetCellValue(j) = .Cells(rngFound.Row, 2).Value
'MsgBox (targetCellValue(j) & " " & j)
End If
Loop
End If
End With
Dim k As Integer
For k = 0 To j
.MultiPage1.Pages("Page1").Controls(comboBoxi).AddItem targetCellValue(k)
Next k
j = 0
Next i
I found a way to do it. The value typed in by a user is not automatically included in the comboBox list therefore you can check it against the list to see if it was there before.
code:
For intComboItem = 0 To .MultiPage1.Pages("Page1").Controls(comboBoxi).ListCount - 1
If .MultiPage1.Pages("Page1").Controls(comboBoxi).Value = .MultiPage1.Pages("Page1").Controls(comboBoxi).List(intComboItem) Then
newDef = False
Exit For
Else
newDef = True
End If
Next
If newDef Then
MsgBox ("new def: " & .MultiPage1.Pages("Page1").Controls(comboBoxi).Value)
End If
Related
Thanks for taking the time to look at this. I'm trying to figure out why this macro works with smaller lists of keywords but when we put in larger lists it doesn't work AND goes too slowly.
Program works like this:
Column A is the input: we paste keywords of interest
Column B is output 1: it populates with all the noise words or stop words that aren't of interest from A. (there will be a 2nd sheet where we can create a list of non-interest words like the, is, by, but, etc)
Column C is output 2: it populates with all the special characters from A.
This is what I have...works with smaller not with bigger sets of words. Been stumped for a while.
Option Explicit
Dim KeywordSearch As Range
Dim NoiseWords As Range
Dim cell As Range
Dim NoiseWord As Range
Dim i As Long , j As Long
Dim NWTable As ListObject
Dim NewRow As ListRow
Dim SCTable As ListObject
Sub Highlight()
Dim s As String
Dim offset As Integer
Dim word As String
Worksheets("Keyword Search").Activate
Set KeywordSearch = ActiveSheet.Range("B3", Range("B3").End(xlDown))
Set NWTable = ActiveSheet.ListObjects("Table1")
Set SCTable = ActiveSheet.ListObjects("SC")
Worksheets("Noise Words").Activate
Set NoiseWords = ActiveSheet.Range("B2", Range("B2").End(xlDown))
' clear table
On Error Resume Next
NWTable.DataBodyRange.ClearContents
Dim r As Range
Set r = NWTable.Range.Rows(1).Resize(2)
NWTable.Resize r
SCTable.DataBodyRange.ClearContents
Dim t As Range
Set t = SCTable.Range.Rows(1).Resize(2)
SCTable.Resize t
On Error GoTo 0
For Each cell In KeywordSearch
s = cell.Value
offset = 1
cell.Interior.Color = vbWhite
cell.Characters.Font.Color = vbBlack
Do
'Replace smart quotes
For j = 1 To Len(s)
cell.Characters(j, 1).Text = Replace(cell.Characters(j, 1).Text, Chr(147), """")
cell.Characters(j, 1).Text = Replace(cell.Characters(j, 1).Text, Chr(148), """")
' Find the special characters and add to SpecialCharacters list
If InStr("""!##$%&'+,.:;<=>?^`{|}~*()/", Mid(s, j, 1)) > 0 Then
cell.Characters(j, 1).Font.Color = vbRed
Set NewRow = SCTable.ListRows.Add
NewRow.Range.Cells(1, 1) = Mid(s, j, 1)
' Replace with spaces
Mid(s, j, 1) = " "
End If
Next
' Find the next space
i = InStr(offset, s, " ")
' If no spaces left then go to end
If i = 0 Then
i = Len(s) + 1
End If
' Extract the word
word = LCase(Mid(s, offset, i - offset))
' Capitalize AND OR NOT
If word = "and" Or word = "not" Or word = "or" Then
For j = 1 To Len(word)
cell.Characters(offset + j - 1, 1).Text = UCase(Mid(word, j, 1))
Next
End If
' Special case to capitalize w/
If word = "w/" And i < Len(s) Then
cell.Characters(i - 2, 2).Text = UCase(word)
End If
' Is the word in the NoiseWord list?
For Each NoiseWord In NoiseWords
If NoiseWord.Value = word Then
' Highlight word
cell.Characters(offset, i - offset).Font.Color = 5287936
' Add to NWList
Set NewRow = NWTable.ListRows.Add
NewRow.Range.Cells(1, 1) = word
Exit For
End If
Next
offset = i + 1
Loop Until i > Len(s)
Next
With NWTable.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("Table1[[#All],[Noise Words]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Apply
End With
NWTable.Range.RemoveDuplicates Columns:=1, Header:=xlYes
SCTable.Range.RemoveDuplicates Columns:=1, Header:=xlYes
Worksheets("Keyword Search").Activate
End Sub
Working with the Characters collection is pretty slow, so you may be stuck with some level of poor performance.
However, there are likely some points where you can shave off time.
E.g:
For j = 1 To Len(s)
cell.Characters(j, 1).Text = Replace(cell.Characters(j, 1).Text, Chr(147), """")
cell.Characters(j, 1).Text = Replace(cell.Characters(j, 1).Text, Chr(148), """")
You don't need to use the characters collection at all here: since you just cleared all of the font color, there's no need to use the Characters approach vs. just replacing via .Value
EDIT: it might be worth setting a flag within to loop to track whether any character-level formatting has been applied, so you can avoid any unneccessary use of .Characters and rely instead on .Value
You can remove this from the loop:
cell.Interior.Color = vbWhite
cell.Characters.Font.Color = vbBlack
and replace with
KeywordSearch.Interior.Color = vbWhite
KeywordSearch.Font.Color = vbBlack
before the loop
This
If word = "and" Or word = "not" Or word = "or" Then
For j = 1 To Len(word)
cell.Characters(offset + j - 1, 1).Text = UCase(Mid(word, j, 1))
Next
End If
could be faster as:
If word = "and" Or word = "not" Or word = "or" Then
cell.Characters(offset, len(word)).Text = UCase(word)
End If
To speed up calculation where you modify values in spreadsheet you need first to disable screen updates and reenable once you finish processing:
Disabling updates:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Reenabling updates:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
The problem is definitely with your use of the Characters collection. If you want to colour the different words found, fine, but do it after you manipulate all the string values.
Side Note: The repeated use of ActiveSheet scares me. Please set this to a variable at the start of the Subroutine and use the variable instead.
Dim Sheet as Worksheet
Set Sheet = ActiveSheet
.
Sheet.Range(...
.
Set Sheet = nothing
Look into reading/writing the data to a Variant instead of a range. (at least for the text manipulation) Here's an example of how to load a Range into a variant:
Dim vNoiseWords as Variant
vNoiseWords = Sheet.Range("B2", Sheet.Range("B2").End(xlDown)).Value2
Writing is just the opposite (but I usually have to transpose the array).
Then, you can go through the variant array and identify the text that needs to be coloured in the cell.
Minimize Any and All Interactions with the Sheet
...so limit any line that starts with ActiveSheet., Cell., Range. and only process it if it needs to be done.
Even Cell = UCase(Cell) is a huge waste of time.
Your much better off doing
Value = UCase(Cell.Value2)
If Value <> Cell.Value2 then Cell.Value2 = Value
Update
FYI, It's easy to pin point the slow parts of your code, by adding timestamps in between sections of code. Here is a simple routine that I use to keep track of time intervals and display the results in the immediate window.
Public Sub TimeStamp(Optional Prompt As String, Optional StartTimer As Boolean)
Static s_fTimer As Single, s_fIntervalTimer As Single
Dim fCurrTime As Single
fCurrTime = Timer
If StartTimer Then
s_fTimer = fCurrTime
s_fIntervalTimer = fCurrTime
End If
If Prompt <> vbNullString Then Prompt = " - " & Prompt
Debug.Print Format((fCurrTime - s_fTimer), "0.000s") & Format((fCurrTime - s_fIntervalTimer), "(0.000s)") & Prompt
s_fIntervalTimer = fCurrTime
End Sub
The first time you call it (or anytime you want to reset the total time counter), you should set the StartTimer = True like this:
TimeStamp "Start of Program", True
After that, just call the routine, with an optional prompt to keep track of the sections of code:
TimeStamp "After Smart Quote Loop"
TimeStamp "The End"
Then just look at the time intervals, find the largest ones and whittle them down if you don't think that they are reasonable. You'll find that every interaction with the UI/cells is the hold up, but processing data in the background takes very little time.
I'm trying to make a function to do the following:
Cycle through all my datasets in my sheet
Cycle through each column in my datasets
Look at the title for that column and check if it is in my list.
Find find a few various other columns, but this time using .Find
Now cycle through each row in the column for that specific dataset
Use the column references found in point 4 and the row from point 5 to put the cell's into a variable that will be used on step 7 which is to insert a formatted comment in the originally found column (for that row).
I've tried getting some code working from what I found on a different site but I can't get it working correct, I'm stuck at part 5.
A data example could look like:
My attempted code looks like:
Sub ComTest()
COMLIST = ";Cond;"
Set rng = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
For Each a In rng.SpecialCells(xlCellTypeConstants).Areas
With a.CurrentRegion
Set r = .Rows(1)
For j = 1 To r.Columns.Count
TitleCell = r.Cells(j).Address
v = ";" & Range(TitleCell).Value & ";"
'-----------------------------------------------------------------------------------------
If InStr(1, COMLIST, v) Then
On Error Resume Next
xRange = .Offset(1).Resize(.Rows.Count - 1).Columns(j).Address
For i = 1 To UBound(xRange)
v = b.Value
Next i
Condw = r.Columns.Find(Replace(v, ";", "") & " " & "w", lookAt:=xlWhole).Column
Condw = .Cells(r, Condw).Address
' Add more stuff here
End If
'-----------------------------------------------------------------------------------------
Next j
End With
Next a
End Sub
As for part 7, the output would essentially be as follows for "row 1" but this part I should be able to do, it's the looping part that I am struggling with.
This question raises a few points that this answer might resolve for you and others in the future:
I note that not many of your previous questions have accepted answers, and that several of them present answers but you have needed to respond by saying it doesn't suit your needs for a certain reason. It suggests you aren't really providing the right details in your question. I think that's the case here. Perhaps you could outline the outcome you are trying to achieve and, especially for Excel VBA, the precise structure of your spreadsheet data. It's tempting to think in this question that you simply want to know how to take the values of Columns C to F and write them to a comment in Column B for any row that contains data.
Using web code can often take more time to understand and adapt than learning the code syntax from first principles. Your provided code is difficult to follow and some parts seem odd. I wonder, for example, what this snippet is meant to do:
xRange = .Offset(1).Resize(.Rows.Count - 1).Columns(j).Address
For i = 1 To UBound(xRange)
v = b.Value
Next i
Using Option Explicit at the top of your module (which forces you to declare your variables) makes VBA coding and debugging much easier, and code submitted on SO is easier to follow if we can see what data types you meant variables to hold.
If your question is merely "How do I take the values of Columns C to F and write them to the cell in Column B for any row that contains data?", then your code could be as simple as:
Dim condCol As Range
Dim cell As Range
Dim line1 As String
Dim line2 As String
Dim cmt As Comment
'Define the "Cond" column range
'Note: this is an unreliable method but we'll use it here for the sake of brevity
Set condCol = ThisWorkbook.Worksheets("Sheet1").UsedRange.Columns("B")
'Delete any comment boxes
condCol.ClearComments
'Loop through the cells in the column and process the data if it's a number
For Each cell In condCol.Rows
If Not IsEmpty(cell.Value) And IsNumeric(cell.Value) Then
'Acquire the comment data
line1 = "Cond: " & cell.Offset(, 1).Value & "/" & cell.Offset(, 2).Value & _
" (" & Format(cell.Offset(, 3), "0.00%") & ")"
line2 = "Cond pl: $" & cell.Offset(, 4).Value
Set cmt = cell.AddComment(line1 & vbCrLf & line2)
'Format the shape
With cmt.Shape.TextFrame
.Characters(1, 5).Font.Bold = True
.Characters(Len(line1 & vbCrLf), 8).Font.Bold = True
.AutoSize = True
End With
End If
Next
If, on the other hand, your question is that you have unreliable data on your spreadsheet and your only certainty is that the headings exist on any one row, then some form of search routine must be added. In that case your code could look like this:
Dim rng As Range
Dim rowRng As Range
Dim cell As Range
Dim condCol(0 To 4) As Long
Dim line1 As String
Dim line2 As String
Dim allHdgsFound As Boolean
Dim i As Integer
Dim cmt As Comment
Set rng = ThisWorkbook.Worksheets("Sheet1").UsedRange
rng.ClearComments
For Each rowRng In rng.Rows
If Not allHdgsFound Then
'If we haven't found the headings,
'loop through the row cells to try and find them
For Each cell In rowRng.Cells
Select Case cell.Value
Case Is = "Cond": condCol(0) = cell.Column
Case Is = "Cond w": condCol(1) = cell.Column
Case Is = "Cond r": condCol(2) = cell.Column
Case Is = "Cond %": condCol(3) = cell.Column
Case Is = "Cond wpl": condCol(4) = cell.Column
End Select
Next
'Check if we have all the headings
'by verifying the condCol array has no 0s
allHdgsFound = True
For i = 0 To 4
If condCol(i) = 0 Then
allHdgsFound = False
Exit For
End If
Next
Else
If Not IsEmpty(rowRng.Cells(1).Value) Then
'The cell has values so populate the comment strings
line1 = "Cond: " & rowRng.Columns(condCol(1)).Value & "/" & _
rowRng.Columns(condCol(2)).Value & _
" (" & Format(rowRng.Columns(condCol(3)).Value, "0.00%") & ")"
line2 = "Cond pl: $" & rowRng.Columns(condCol(4))
Set cmt = rowRng.Columns(condCol(0)).AddComment(line1 & vbCrLf & line2)
'Format the shape
With cmt.Shape.TextFrame
.Characters(1, 5).Font.Bold = True
.Characters(Len(line1 & vbCrLf), 8).Font.Bold = True
.AutoSize = True
End With
Else
'We've reached a blank cell so re-set the found values
allHdgsFound = False
Erase condCol
End If
End If
Next
Of course your data might be structured in any number of other ways, but we don't know that. My point is that if you can be more specific in your question and provide an outcome you are trying to achieve, you are likely to receive answers that are more useful to you.
What I'm looking to do is comb through a column and pull all the unique identifiers out of that column and then paste the results in a table in a different worksheet. I found the code below and it is very close to what I need. However, I have two major problems with it that I cannot figure out. First the area that this macro searches is constant ie "A1:B50". I need this to be one column and be dynamic since more data and new unique identifiers will be added to this worksheet. Second I cannot figure out how to paste my results to a specific range on a different worksheet. For example if I wanted to take the results and paste them in "sheet2" starting in at "B5" and going to however long the list of unique identifiers is.
Sub ExtractUniqueEntries()
Const ProductSheetName = "Sheet1" ' change as appropriate
Const ProductRange = "B2:B"
Const ResultsCol = "E"
Dim productWS As Worksheet
Dim uniqueList() As String
Dim productsList As Range
Dim anyProduct
Dim LC As Integer
ReDim uniqueList(1 To 1)
Set productWS = Worksheets(ProductSheetName)
Set productsList = productWS.Range(ProductRange)
Application.ScreenUpdating = False
For Each anyProduct In productsList
If Not IsEmpty(anyProduct) Then
If Trim(anyProduct) <> "" Then
For LC = LBound(uniqueList) To UBound(uniqueList)
If Trim(anyProduct) = uniqueList(LC) Then
Exit For ' found match, exit
End If
Next
If LC > UBound(uniqueList) Then
'new item, add it
uniqueList(UBound(uniqueList)) = Trim(anyProduct)
'make room for another
ReDim Preserve uniqueList(1 To UBound(uniqueList) + 1)
End If
End If
End If
Next ' end anyProduct loop
If UBound(uniqueList) > 1 Then
'remove empty element
ReDim Preserve uniqueList(1 To UBound(uniqueList) - 1)
End If
'clear out any previous entries in results column
If productWS.Range(ResultsCol & Rows.Count).End(xlUp).Row > 1 Then
productWS.Range(ResultsCol & 2 & ":" & _
productWS.Range(ResultsCol & Rows.Count).Address).ClearContents
End If
'list the unique items found
For LC = LBound(uniqueList) To UBound(uniqueList)
productWS.Range(ResultsCol & Rows.Count).End(xlUp).Offset(1, 0) = _
uniqueList(LC)
Next
'housekeeping cleanup
Set productsList = Nothing
Set productWS = Nothing
End Sub
I think your solution is a bit more tricky than it needs to be. Collecting unique ids becomes almost trivial is you use a Dictionary instead of a list. The added benefit is that a dictionary will scale much better than a list as your data set becomes larger.
The code below should provide you with a good starting point to get you going. For convenience's sake I used the reference from your post. So output will be on sheet2 to starting in cell B5 going down and the input is assumed to be on sheet1 cell B2 going down.
If you have any questions, please let me know.
Option Explicit
Sub ExtractUniqueEntries()
'enable microsoft scripting runtime --> tools - references
Dim unique_ids As New Dictionary
Dim cursor As Range: Set cursor = ThisWorkbook.Sheets("Sheet1").Range("B2") 'change as Required
'collect the unique ids
'This assumes that:
'1. ids do not contain blank rows.
'2. ids are properly formatted. Should this not be the could you'll need to do some validating.
While Not IsEmpty(cursor)
unique_ids(cursor.Value) = ""
Set cursor = cursor.Offset(RowOffset:=1)
Wend
'output the ids to some target.
'assumes the output area is blank.
Dim target As Range: Set target = ThisWorkbook.Sheets("Sheet2").Range("B5")
Dim id_ As Variant
For Each id_ In unique_ids
target = id_
Set target = target.Offset(RowOffset:=1)
Next id_
End Sub
A small modification will do it; the key is to define the ProductRange.
Sub ExtractUniqueEntries()
Const ProductSheetName = "Sheet1" ' change as appropriate
Dim ProductRange
ProductRange = "B2:B" & Range("B" & Cells.Rows.Count).End(xlUp).Row
Const ResultsCol = "E"
Dim productWS As Worksheet
Dim uniqueList() As String
Dim productsList As Range
Dim anyProduct
Dim LC As Integer
ReDim uniqueList(1 To 1)
Set productWS = Worksheets(ProductSheetName)
Set productsList = productWS.Range(ProductRange)
Application.ScreenUpdating = False
For Each anyProduct In productsList
If Not IsEmpty(anyProduct) Then
If Trim(anyProduct) <> "" Then
For LC = LBound(uniqueList) To UBound(uniqueList)
If Trim(anyProduct) = uniqueList(LC) Then
Exit For ' found match, exit
End If
Next
If LC > UBound(uniqueList) Then
'new item, add it
uniqueList(UBound(uniqueList)) = Trim(anyProduct)
'make room for another
ReDim Preserve uniqueList(1 To UBound(uniqueList) + 1)
End If
End If
End If
Next ' end anyProduct loop
If UBound(uniqueList) > 1 Then
'remove empty element
ReDim Preserve uniqueList(1 To UBound(uniqueList) - 1)
End If
'clear out any previous entries in results column
If productWS.Range(ResultsCol & Rows.Count).End(xlUp).Row > 1 Then
productWS.Range(ResultsCol & 2 & ":" & _
productWS.Range(ResultsCol & Rows.Count).Address).ClearContents
End If
'list the unique items found
For LC = LBound(uniqueList) To UBound(uniqueList)
productWS.Range(ResultsCol & Rows.Count).End(xlUp).Offset(1, 0) = _
uniqueList(LC)
Next
'housekeeping cleanup
Set productsList = Nothing
Set productWS = Nothing
End Sub
I am trying to automate a spreadsheet to transfer data from one sheet to another sheet depending on what the first 3 characters of the data is. So for example, for the data NDX 12/31/2012 P2600, I would like it to be placed in the NDX sheet. So I have an array (desArr()) that splits that data into different positions of the array, such that desArr(0) contains "NDX", desArr(1) contains "12/31/2012" and so on.
The part I am having trouble with is moving the data to the respective sheets. Specifically, I need a variable reference to these spreadsheets. For instant, take the NDX sheet. I know I can just do NDX.cells(1,1).Paste or Worksheets(NDX.Name).Cells(1,1).Paste and that would work, but what if I want to do that for multiple sheets? I could obviously use If statements to define each different instance, but I wanted to shorten my code. Hence, I am trying to make the reference to the sheet objects variable, i.e. desArr(0).Name, but it returns with an error (which I understand why). Anyone with suggestions on how to achieve this? I know one solution is to just use the name property of the worksheet, but I wanted to avoid the chance of my code failing if someone changed the name of the sheets.
So perhaps like:
Dim desArr() As String, desInfo As String, opType As String
Dim rNum As Long, cNum As Long, i As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim sortRng As Range, findRng As Range
Dim j As Integer 'Throw away after testing
Dim test As String 'Throw away after testing
Dim k As Integer 'Throw away after testing
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb = ThisWorkbook
Set ws = wb.Worksheets(Import.Name)
With ws
rNum = .Range("C1048576").End(xlUp).Row
cNum = 6 'Number of used columns starting from left
Set sortRng = .Range(.Cells(3, 2), .Cells(rNum, cNum))
'Sort range according to Type and Description
sortRng.Sort _
Key1:=.Range("B1"), _
Key2:=.Range("C1")
'Apply conditional formatting
With sortRng.Columns(2)
.FormatConditions.AddUniqueValues
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).DupeUnique = xlDuplicate
With sortRng.Columns(2).FormatConditions(1)
.Interior.PatternColorIndex = xlAutomatic
.Interior.Color = 13551615
.Interior.TintAndShade = 0
.StopIfTrue = False
End With
End With
For i = 0 To (rNum - 2)
With sortRng.Cells(i + 1, 2)
If .DisplayFormat.Interior.Color = "13551615" Then
j = 0
While (.Value = .Offset(j + 1, 0).Value And .Offset(0, 1).Value = .Offset(j + 1, 1).Value)
j = j + 1
Wend
If (j <> 0) Then 'There are duplicates
End If
End If
'Converting the description to format used for classification
If .Offset(0, -1) = "Ext Option" Then
desArr = Split(.Value, " ")
If Not (Left(.Value, 3) = "SX5" Or Left(.Value, 3) = "UKX") Then
'check if it's a call or put
If Left(desArr(3), 1) = "C" Then
opType = "Call"
ElseIf Left(desArr(3), 1) = "P" Then
opType = "Put"
Else
opType = "N/A"
End If
desInfo = Format(desArr(2), "mmmdd") & " " & Right(Trim(desArr(3)), Len(Trim(desArr(3))) - 1) & " " & opType
Else
'check if it's a call or put
If Left(desArr(2), 1) = "C" Then
opType = "Call"
ElseIf Left(desArr(2), 1) = "P" Then
opType = "Put"
Else
opType = "N/A"
End If
desInfo = Format(desArr(1), "mmmdd") & " " & Right(Trim(desArr(2)), Len(Trim(desArr(2))) - 1) & " " & opType
End If
End If
End With
Next i
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Except that NDX would have to be variable as which worksheet to move the data to depends on the data.
You can use the codename property of the worksheets. If you use NDX.Cells(1,1), NDX is the codename of the sheet. simply search all worksheets, e.g.:
Function GetWorksheet(byval withCodename as String) as Worksheet
Dim sheetVar as Worksheet
For each sheetVar in ThisWorkbook.Worksheets
If sheetVar.CodeName = withCodename Then
Set GetWorksheet = sheetVar
End if
Next
End Function
You could:
Prevent user from renaming sheets
You wrote: "I wanted to avoid the chance of my code failing if someone changed the name of the sheets."
Well, the user can't do this:
If you protect the workbook. You can do this manually in the ribbon (Review > Changes > Protect workbook), or programmatically like this:
ThisWorkbook.Protect 'optionally, add a password -- see documentation for Protect
This will entirely prevent the user from changing sheet names.
I have the following code. It searches one column for a specific value. It works fine, but if the cell have line break, the code does not search the second line.
vardestinolinha = ThisWorkbook.Sheets("base").Range("a11").End(xlDown).Row
a = 10
k = a
For i = a To vardestinolinha
Search = ThisWorkbook.Sheets(NomeTabela).Range("a2")
Replacement = ThisWorkbook.Sheets(NomeTabela).Range("c" & i)
varposicao = ThisWorkbook.Sheets(NomeTabela).Range("b" & i) '''''
Set rngFind = ThisWorkbook.Sheets("base").Columns(2).Find(What:=Search, LookIn:=xlValues, lookat:=xlPart)
Do While Not rngFind Is Nothing
tamanho = Len(rngFind)
p = InStr(1, rngFind, Search, vbTextCompare)
If p > 0 Then
ThisWorkbook.Sheets("base").Cells(k, 5) = ThisWorkbook.Sheets("base").Cells(k, 3)
k = k + 1
End If
Set rngFind = ThisWorkbook.Sheets("base").Columns(2).FindNext
Loop
k = i + 1
Next
I want the code to search an entire cell even when there are line breaks.
If the text was entered in the cell useing the Alt+Enter method you can use this in your VBA:
" & Chr(10) & "
Here is the .Find method that I have used.
Private Sub CommandButton1_Click()
Set RngClosedDate = Range("A1:Z10").Find(What:="Closed" & Chr(10) & "(Date)", LookAt:=xlWhole, LookIn:=xlValues)
' If the text that is searched for from the line above is not found then a message box is displayed and sub function is exitied
If RngClosedDate Is Nothing Then
MsgBox "Closed (Date) Column Header Not found. Cannot sort or format records."
Exit Sub
End If
End Sub