I used another answer on SO to be able to convert an HTML string to displayed rich text in excel.
However, it comes with a nasty side effect of not being able to add data for multiple lines in a single cell (recommendation I found was to remove the paste logic).
Ideally, I'd like to NOT use the CreateObject for Internet Explorer in my solution, and just get the paste to work properly.
Here's the code that is found using a dictionary that does the paste to each cell.
How do I accomplish both the conversion of an HTML string to text AND paste multiple lines to a single cell?
' Sort By Years Descending
Dim yearKey As Variant
Dim firstYear As Boolean
Dim cellData As String
firstYear = True
cellData = "<HTML><DIV>"
For Each yearKey In stakeholderEvents(stakeholder).Keys
If Not firstYear Then
cellData = cellData & "<DIV></DIV>" ' Add Extra Blank Line
End If
cellData = cellData & "<B>" & yearKey & "</B>" & "<UL>" ' Add Year
' Loop Through Events For Year
Dim eventItem As Variant
For Each eventItem In stakeholderEvents(stakeholder)(yearKey)
cellData = cellData & "<LI>" & eventItem & "</LI>"
Next
cellData = cellData & "</UL>"
firstYear = False
Next
cellData = cellData & "<DIV></BODY></HTML>"
Set clipboardData = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
clipboardData.SetText cellData
clipboardData.PutInClipboard
Sheet1.Activate
'Sheet1.Range (Sheet1.Cells(rowIndex, stakeholderEventsColumn).Address)
Sheet1.Cells(rowIndex, stakeholderEventsColumn).Select
'Sheet1.Cells(rowIndex, stakeholderEventsColumn).Select
Sheet1.PasteSpecial Format:="Unicode Text"
HTML alternative (reference Excel-friendly html: keeping a list inside a single cell) :
Set clipboardData = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
clipboardData.SetText "<table><style>br {mso-data-placement:same-cell}</style><tr><td>" _
& "<b>Line 1</b><br>Line 2<br>Line 3"
clipboardData.PutInClipboard
Sheet1.Range("b2").PasteSpecial
XML alternative (the XML can be adjusted by analyzing the .Value(11) of a formatted cell) :
Dim c As Range
Set c = Sheet1.Range("b2")
c.Value = vbLf
c.Value(11) = Replace(c.Value(11), "<Data ss:Type=""String"">
</Data>", _
"<ss:Data ss:Type=""String"" xmlns=""http://www.w3.org/TR/REC-html40"">" & _
"<B>Line 1</B>
Line 2
Line 3</ss:Data>")
I think the problem is that you're using HTML for formatting, and Excel is always going to paste the HTML so that block-level elements go into different cells.
Another approach would be to use Excel's built-in formatting instead of using HTML tags. This will also let you eschew using the Clipboard object. Here's an example of adding some text to a range, and then formatting some of the text differently (i.e. bolding):
Public Sub PopulateHtmlData()
Dim cell As Excel.Range
Dim s1 As String, s2 As String
s1 = "Item 1"
s2 = "Item 2"
Set cell = Excel.Range("$A$1")
' use Chr(10) to add a new line in the cell
cell.Value = s1 & Chr(10) & s2
cell.Characters(0, Len(s1) - 1).Font.Bold = True
End Sub
Related
I have 20 cases. For every row in my sheet, I have a cell that assigns related case numbers to it. A row could have multiple case numbers assigned to it in that cell (Example: 1,2,11,12)
I am writing a code to copy all the rows that have Case number 1 assigned to them, copy them someplace else..
and then go to case number 2 and repeat the same..
This is what I am using:
For CaseNumbers = 1 To 20
For i = Row1 To RowLast
If InStr(1, Range(CaseNoCell & i).Value, CaseNumbers & ",") Then
COPY AND PASTE CODE
End If
Next
Next
The problem I am facing is, the code considers case number 11 as case number 1 too (since it has the digit 1).
This is the first time I am writing a VBA code and I have no background in this.
Can someone please advise on better way of doing this? Should I assign a checklist instead to each row?
All I want to do is find all the rows that have Case number 1 assigned, copy them.. then find all the rows that have Case 2 assigned, copy them.. and so on.
Please help.
You can use a function to do the test
Public Function isCaseNumberIncluded(ByVal caseToCheck As Long, ByVal caseNumbers As String) As Boolean
'add , to make all values distinct
caseNumbers = "," & caseNumbers & ","
Dim strCaseToCheck As String
strCaseToCheck = "," & caseToCheck & ","
If InStr(1, caseNumbers, strCaseToCheck) > 0 Then
isCaseNumberIncluded = True
End If
End Function
You would call this function within your main code like this:
Dim caseNumber As Long 'I removed the s - as this could be misleading in my eyes
For caseNumber = 1 To 20
For i = Row1 To RowLast
If isCaseNumberIncluded(caseNumber, Range(CaseNoCell & i).Value) Then
COPY AND PASTE CODE
End If
Next
Next
Using a separate function to run the test has two advantages:
your code gets more readable, ie you know from reading the functions name what the result should be - without reading the whole code how to do it :-)
you can re-use this code propably at another place
Or you can test the function first:
Public Sub test_isCaseNumberIncluded()
Debug.Print isCaseNumberIncluded(1, "1,2,11,12"), "Should be true"
Debug.Print isCaseNumberIncluded(1, "2,11,12"), "Should be false"
Debug.Print isCaseNumberIncluded(11, "1,2,11,12"), "Should be true"
Debug.Print isCaseNumberIncluded(11, "1,2,12"), "Should be false"
End Sub
Well, you are working with this piece of code:
If InStr(1, Range(CaseNoCell & i).Value, CaseNumbers & ",") Then
This checks against 1,, 12,, ..., but obviously it won't cover the last entry so that's something you'll need to add. And you have the problem that 11, gets treated as 1,.
In a similar way you can use this piece of code:
If InStr(1, Range(CaseNoCell & i).Value, "," & CaseNumbers & ",") Then
This checks against ,1,, ,12,, ... so it will solve your error, but obviously it won't cover the last and the first entry so that's something you'll need to add.
This is something that should be encapsulated in a function rather than being done in line. The method provided in VBA for tokenising a string is 'Split'.
You could wite a function that checks tokens 1 by 1, or which compile a collection of the tokens which then uses a built checking method of the collection to determine if the specified token is present or not.
In this specific case I've chosen to use the collection method. The specific object for the collection is the ArrayList (but a Scripting.Dictionary is also possible). The function contains checks for zero length strings and allows the seperator to be specified if it isn't a comma.
Option Explicit
Function FindToken(ByVal ipToken As String, ByVal ipTokenList As String, Optional ByVal ipSeparator As String = ",") As Boolean
' Guard against ipSeparator being vbnullstring
Dim mySeparator As String
mySeparator = IIf(VBA.Len(ipSeparator) = 0, ",", ipSeparator)
'Raise an error if ipToken or ipTokenList are empty strings
If VBA.Len(ipToken) = 0 Or VBA.Len(ipTokenList) = 0 Then
Err.Raise 17, "Empty string error"
End If
'Convert the token list to tokens
Dim myTokens As Variant
myTokens = VBA.Split(ipTokenList, mySeparator)
' Put the tokens in an ArrayList so we can use the contains method
' no point is doing early binding as arraylist doesn't provide intellisense
Dim myAL As Object
Set myAL = CreateObject("System.Collections.ArrayList")
Dim myItem As Variant
For Each myItem In myTokens
' Trim just in case there are spaces
myAL.Add VBA.Trim(myItem)
Next
'Finally test if the Token exists in the token list
Find = myAL.contains(VBA.Trim(ipToken))
End Function
This means that your code
If InStr(1, Range(CaseNoCell & i).Value, CaseNumbers & ",") Then
can now be rewritten as
If FindToken(CStr(CaseNUmbers), Range(CaseNoCell & cstr(i)).Value) Then
Identify Criteria Rows
Option Explicit
Sub Test()
Const WordSeparator As String = ","
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim CaseNumber As Long
Dim i As Long
Dim cValue As Variant
Dim cString() As String
For CaseNumber = 1 To 20
For i = Row1 To RowLast
cValue = CStr(ws.Range(CaseNoCell & i).Value)
If Len(cValue) > 0 Then
cString = Split(cValue, WordSeparator)
If IsNumeric(Application.Match( _
CStr(CaseNumber), cString, 0)) Then
' CopyAndPasteCode CaseNumber
Debug.Print "Case " & CaseNumber & ": " & "Row " & i
End If
End If
Next i
Next CaseNumber
End Sub
How am I able to remove the comma without removing the strikethrough format
Example: C418, C419, C420 , C421, C422, C423, C424
Expected Result: C418 C419 C420 C421 C422 C423 C424
Final Result: C418, C419 C420 C421 C422 C423 C424
I am checking to see if that cell contain a strikethrough. By using the Function I am able to detect it. But once I try to remove the comma by using the replace function and replace comma with a blank. The format for the strikethrough will be remove causing the function not to work which will result in a different outcome.
I will like to use the space delimiter to match with the other cell so that I can split the cell value afterwards
If HasStrikethrough(BOMCk.Sheets("Filtered RO BOM").Range("B" & LCB)) = True Then
BOMCk.Sheets("Filtered RO BOM").Range("B" & LCB).Value = Replace(BOMCk.Sheets("Filtered RO BOM").Range("B" & LCB).Value, ",", "")
BOMCk.Sheets("Filtered RO BOM").Range("G" & LCB).Value = "strike-off"
ElseIf HasStrikethrough(BOMCk.Sheets("Filtered RO BOM").Range("B" & LCB)) = False Then
BOMCk.Sheets("Filtered RO BOM").Range("B" & LCB).Value = Replace(BOMCk.Sheets("Filtered RO BOM").Range("B" & LCB).Value, ",", "")
End If
Function HasStrikethrough(rng As Range) As Boolean
Dim i As Long
With rng(1)
For i = 1 To .Characters.Count
If .Characters(i, 1).Font.StrikeThrough Then
HasStrikethrough = True
Exit For
End If
Next i
End With
End Function
Range.Characters only works if the cells value is 255 characters or less.
Range.Characters(i, 1).Delete will delete the commas. Make sure to iterate from the last position to the first position when deleting.
Sub RemoveCommas(ByVal Target As Range)
If Target.Characters.Count > 255 Then
MsgBox "Range.Characters only works with String with 255 or less Characters", vbCritical, "String too long"
Exit Sub
End If
Dim n As Long
For n = Target.Characters.Count To 1 Step -1
If Target.Characters(n, 1).Text = "," Then Target.Characters(n, 1).Delete
Next
End Sub
Alternative via xlRangeValueXMLSpreadsheet Value
The ►.Value(11) approach solves the question by a very simple string replacement (though the xml string handling can reveal to be very complicated in many other cases):
Sub RemoveCommata(rng As Range, Optional colOffset As Long = 1)
'a) Get range data as xml spreadsheet value
Dim xmls As String: xmls = rng.Value(xlRangeValueXMLSpreadsheet) ' //alternatively: xmls = rng.Value(11)
'b) find start position of body
Dim pos As Long: pos = InStr(xmls, "<Worksheet ")
'c) define xml spreadsheet parts and remove commata in body
Dim head As String: head = Left(xmls, pos - 1)
Dim body As String: body = Replace(Mid(xmls, pos), ",", "")
'd) write cleaned range back
rng.Offset(0, colOffset).Value(11) = head & body
End Sub
Help reference links
Excel XlRangeValueDataType enumeration
Excel Range Value
I have below text in Excel cell:
$abcd.$efghijk.$lmn.$op.$qrst.
I want above text in following format in Excel cell using Excel formula only:
abcd$abcd.efghijk$efghijk.lmn$lmn.op$op.qrst$qrst.
Here's what I will suggest based on discussion.
In a general module, insert following code.
Public Function RepeatCustom(strInput As String) As String
Dim varInput As Variant
Dim i As Long
If Len(strInput) = 0 Then
RepeatCustom = ""
Else
varInput = Split(strInput, ".")
For i = LBound(varInput) To UBound(varInput)
RepeatCustom = RepeatCustom & " " & Mid(varInput(i), 2, Len(varInput(i))) & varInput(i)
Next
RepeatCustom = Replace(Trim(RepeatCustom), " ", ".") & "."
End If
End Function
And then assuming cell containing original data is A2, you can use above UDF:
=RepeatCustom(A2)
Just note that the code is minimum and is based on sample posted.
I have some number in a column in excel like this:
201
202
208-1
210
when I sort this column, sorted column is like below:
201
202
210
208-1
How do I sort this column? I want the sorted column becomes like this:
201
202
208-1
210
or
210
208-1
202
201
One option is a hidden column, say if your values listed above were in A2:A5, insert a column to the right and in B2 enter the formula below and copy this down to the other B cells:
=IFERROR(VALUE(LEFT(A2,FIND("-",A2)-1)),VALUE(A2))
or alternative suggested by #Gary'sStudent that handles values after the hyphen as well by converting to decimals:
=IFERROR(VALUE(SUBSTITUTE(A2,"-",".")),VALUE(A2))
This strips out the number up to the first hyphen. Select all of the values in the two columns, select sort and then sort by columnB. you can then right click on column B and select hide.
If you do not want to use hidden columns then I think your only option would be to write some VBA to do a custom sort procedure. You would then also need a way of triggering this such as a control in the spreadsheet or just a keyboard shortcut.
UPDATE
I have had a go at the VBA procedure, it was not as straight forward as I expected so it may be that there is an easier way to do this.
The basic steps I went through are to prompt the user for a cell range (you just have to select the cells when prompted), store the values to an array of strings, create an equivalent numeric array where the hyphens are replaced by decimal points, sort the numeric array and then loop through the initial range pasting in the values in order.
I was surprised to find out that VBA does not have a built in method for sorting an array, but found some code that could be used here. This creates a temp worksheet and uses the worksheet function, there is also code there for a pure VBA solution but it's pretty lengthy.
To create the VBA procedure you will need to open the VBA editor with alt F11 and create a new module then paste the code below into a module (create a new module - right click on modules on right and insert) then paste in the code below.
The procedure that you need to call is sort_with-hyphens.
You will need to create a control or create a keyboard short cut to trigger this. For either you will need to enable the developer ribbon tab through File>Options. For the control do developer>control>button and right click to assign a macro. For the keyboard short cut developer>Macros select the VBA procedure name from the list of macros and select options.
Sub sort_with_hyphens()
On Error GoTo sort_with_hyphens_err
Dim vRange As Range
Dim vCell As Variant
Dim vStrArray(), vNumArray()
Dim i As Long, vStart As Long, vEnd As Long
Dim vStep As String: vStep = "Initialising values"
' prompt user to specify range
Set vRange = Application.InputBox("Select a range to be sorted", _
"Obtain Range Object", _
Type:=8)
vStrArray = vRange.Value
vStart = LBound(vStrArray)
vEnd = UBound(vStrArray)
ReDim vNumArray(vStart To vEnd)
vStep = "Populating Numeric Array"
' loop through array copying strings with hyphen to decimal equivalent
For i = vStart To vEnd
vNumArray(i) = Val(Replace(vStrArray(i, 1), "-", "."))
Debug.Print i, vNumArray(i)
Next i
' sort numeric array
vStep = "Sorting Numeric Array"
SortViaWorksheet vNumArray
' write out sorted values
vStep = "Writing out Sorted Values"
For i = vStart To vEnd
' convert back to string and switch periods back to hyphens
vRange.Cells(i, 1).Value = Replace(CStr(vNumArray(i)), ".", "-")
Next
sort_with_hyphens_exit:
Exit Sub
sort_with_hyphens_err:
If vStep = "Writing out Sorted Values" Then
MsgBox ("An error has occurred, the original values will " & _
"be restored. Error in Step: " & vStep & vbCrLf & _
"Error Details:" & vbCrLf & err.Number & " - " & _
err.Description)
For i = vStart To vEnd
' replace with original value incase of error
vRange.Cells(i, 1).Value = vStrArray(i)
Next
Else
MsgBox ("An error has occurred in Step: " & vStep & vbCrLf & _
"Aborting sort procedure." & vbCrLf & _
"Error Details:" & vbCrLf & err.Number & " - " & _
err.Description)
End If
End Sub
Sub SortViaWorksheet(pArray)
Dim WS As Worksheet ' temporary worksheet
Dim R As Range
Dim N As Long
Application.ScreenUpdating = False
' create a new sheet
Set WS = ThisWorkbook.Worksheets.Add
' put the array values on the worksheet
Set R = WS.Range("A1").Resize(UBound(pArray) - LBound(pArray) + 1, 1)
R = Application.Transpose(pArray)
' sort the range
R.Sort key1:=R, order1:=xlAscending, MatchCase:=False
' load the worksheet values back into the array
For N = 1 To R.Rows.Count
pArray(N) = R(N, 1)
Next N
' delete the temporary sheet
Application.DisplayAlerts = False
WS.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
' test/debug/confirmation
Debug.Print vbCrLf & "Sorted Array:" & vbCrLf & "------------"
For N = LBound(pArray) To UBound(pArray)
Debug.Print N, pArray(N)
Next N
End Sub
Let me know if you have any questions.
I am fairly new to Excel Macros and I am looking for a way to loop through the row headings and columns headings and combine them into one cell for each row and column heading until I have combined all of them.
An example of the First Column cell would be "Your Organizations Title"
An Example of the First Row Cell Would be "22. Cheif Investment Officer"
An example of the first combined cell that I want on a new sheet would be this: "22. Chief Investment Officer (Your Organization's Title)
I then want the combined cells on the new sheet to offset one column to the right until it has iterated through all of the rows and columns.
I have just joined the forum and it will not let me post images or I would have. Perhaps this gives a better idea, here is my code now:
Sub Fill()
' Select cell A2, *first line of data*.
Set title = Sheets("Compensation, 3").Range("B6:B500")
Set descr = Sheets("Compensation, 3").Range("C5:AAA5")
' Set Do loop to stop when an empty cell is reached.
Do Until IsEmpty(title.Value)
Do Until IsEmpty(descr.Value)
ActiveCell.Offset(0, 1).Formula = _
"=title.value & "" ("" & descr.value & "")"""
Set descr = descr.Offset(0, 1)
Loop
Set title = title.Offset(1, 0)
Loop
End Sub
When I run it goes puts this into the active cell:
=title.value & " (" & descr.value & ")"
It does not recognize the variables and come up with the NAME error. It also goes into an infinite loop with no output besides the one cell.
Edit:
I cannot answer my own question because I am new to the forum, but using a combination of your answers I have solved the problem!
Here is the finished code:
Sub Fill()
' Select cell A2, *first line of data*.
Set title = Sheets("Compensation, 3").Range("B6")
Set descr = Sheets("Compensation, 3").Range("C5")
offsetCtr = 0
' Set Do loop to stop when an empty cell is reached.
Do Until IsEmpty(title.Value)
Do Until IsEmpty(descr.Value)
ActiveCell.Offset(0, offsetCtr).Formula = title.Value & " (" & descr.Value & ")"
offsetCtr = offsetCtr + 1
Set descr = descr.Offset(0, 1)
Loop
Set descr = Sheets("Compensation, 3").Range("C5")
Set title = title.Offset(1, 0)
Loop
End Sub
Thank you so much!
Option Explicit
Sub GenerateAndPasteFormulaForTitleAndDescription( _
ByVal titlesRange As Range, ByVal descriptionRange As Range, _
ByVal startCellOnDestination As Range)
Dim title As Range
Dim descr As Range
Dim offsetCtr As Long
Dim formulaTemplate As String
Dim newFormula As String
formulaTemplate = "=CONCATENATE([1], '(', [2], ')')"
startCellOnDestination.Worksheet.EnableCalculation = False
For Each title In titlesRange.Cells
For Each descr In descriptionRange.Cells
If title.Value <> "" And descr.Value <> "" Then
newFormula = Replace(formulaTemplate, "[1]", _
title.Address(External:=True))
newFormula = Replace(newFormula, "[2]", _
descr.Address(External:=True))
newFormula = Replace(newFormula, "'", Chr(34))
startCellOnDestination.Offset(0, offsetCtr).Formula = newFormula
offsetCtr = offsetCtr + 1
End If
Next
Next
startCellOnDestination.Worksheet.EnableCalculation = True
End Sub
Here is how to call the above procedure
GenerateAndPasteFormulaForTitleAndDescription _
Sheets("Compensation, 3").Range("B6:B500"), _
Sheets("Compensation, 3").Range("C5:AAA5"), _
Sheets("new sheet").Range("B5")
EDIT: The code loops through combination of title and description, checks if both of them aren't empty and creates a formula. It pastes the formula into the start cell (Sheets("new sheet").Range("B5") in this case) and moved ahead and pastes the next formula in the column next to it
Basically, you are trying to use VBA objects in worksheet functions. It doesn't quite work that way.
Try replacing
"=title.value & "" ("" & descr.value & "")"""
with
=title.value & " (" & descr.value & ")"