Copy Range and paste it into a insert comment Part 2

[Shazam]

Hi everyone,

I wasn't sure to make a new thread on this because the original thread I marked it solved.

I tried to modified rory and xld codes to work on 2 ranges ( Columns A & B ) but it does not work. I would like to copy 2 ranges of columns A & B and paste it into a insert comment. I posted sample workbook below look in cell A2.


Here is the link below where it started.

http://vbaexpress.com/forum/showthread.php?t=14092

[Charlize]

maybe use offset and count the length of the longest word to add spaces in between.

[rory]

Can I ask what the reason for doing this is? There may be better ways of achieving what you want.

[rory]

The problem is that if you need it to line up, you either need to use a fixed width font, or actually work out the width of the individual characters for each line! If you use a fixed width font, you can do something like this:
Sub Test()
Dim mpCell As Range, rngCheck As Range
Dim mpTemp As String, lngCellLen As Long, lngindex As Long
Dim varData
With Worksheets("Range")
Set rngCheck = .Range(.Range("A2:B2"), .Range("A2").End(xlDown))
For Each mpCell In rngCheck
If lngCellLen < Len(mpCell.Text) Then lngCellLen = Len(mpCell.Text)
Next mpCell
End With
varData = rngCheck
For lngindex = 1 To UBound(varData, 1)
mpTemp = mpTemp & vbLf & varData(lngindex, 1) & Space(lngCellLen + 2 - Len(varData(lngindex, 1))) & varData(lngindex, 2)
Next lngindex
With Worksheets("Expected Results").Range("A2")
On Error Resume Next
.Comment.Delete
On Error GoTo 0
.AddComment "Part" & Space(lngCellLen - 2) & "QTY" & mpTemp
.Comment.Shape.TextFrame.Characters.Font.Name = "FixedSys"
End With

End Sub

[Shazam]

Sorry everyone lost track of time,busy at work.



maybe use offset and count the length of the longest word to add spaces in between.


Thanks Charlize I did not think of that. I did what you said and it works great.



The problem is that if you need it to line up, you either need to use a fixed width font, or actually work out the width of the individual characters for each line! If you use a fixed width font, you can do something like this:


Very nice code thank you. One more question say for instance in the insert comment I would like to bold the words "Part" & "Qty" only, Is there a line of code for that?

[rory]

Sure - use this:
Sub Test()
Dim mpCell As Range, rngCheck As Range
Dim mpTemp As String, lngCellLen As Long, lngindex As Long
Dim varData
With Worksheets("Range")
Set rngCheck = .Range(.Range("A2:B2"), .Range("A2").End(xlDown))
For Each mpCell In rngCheck
If lngCellLen < Len(mpCell.Text) Then lngCellLen = Len(mpCell.Text)
Next mpCell
End With
varData = rngCheck
For lngindex = 1 To UBound(varData, 1)
mpTemp = mpTemp & vbLf & varData(lngindex, 1) & Space(lngCellLen + 2 - Len(varData(lngindex, 1))) & varData(lngindex, 2)
Next lngindex
With Worksheets("Expected Results").Range("A2")
On Error Resume Next
.Comment.Delete
On Error GoTo 0
.AddComment "Part" & Space(lngCellLen - 2) & "QTY" & mpTemp
With .Comment.Shape.TextFrame
.Characters.Font.Name = "Courier New"
.Characters(1, 4).Font.Bold = True
.Characters(lngCellLen + 3, 3).Font.Bold = True
.AutoSize = True
End With
End With

End Sub

[Bob Phillips]

Sub Test()
Dim mpCell As Range, rngCheck As Range
Dim mptemp As String, lngcelllen As Long, lngindex As Long
Dim varData
With Worksheets("Range")
Set rngCheck = .Range(.Range("A2:B2"), .Range("A2").End(xlDown))
For Each mpCell In rngCheck
If lngcelllen < Len(mpCell.Text) Then lngcelllen = Len(mpCell.Text)
Next mpCell
End With
varData = rngCheck
For lngindex = 1 To UBound(varData, 1)
mptemp = mptemp & vbLf & varData(lngindex, 1) & Space(lngcelllen + 2 - Len(varData(lngindex, 1))) & varData(lngindex, 2)
Next lngindex
With Worksheets("Expected Results").Range("A2")
On Error Resume Next
.Comment.Delete
On Error GoTo 0
.AddComment "Part" & Space(lngcelllen - 2) & "QTY" & mptemp
With .Comment.Shape.TextFrame
.Characters.Font.Name = "FixedSys"
.Characters(1, 4).Font.Bold = True
.Characters(lngcelllen + 3, 3).Font.Bold = True
End With
End With

End Sub

[Shazam]

Thank you so much rory & xld the codes you provided are great. I modified the code just a bit to get the correct format and the aligment in the insert comment and it looks great.

Once again thank you very much!!

One more question how can we auto format the length?

I use this line below, but it will auto size the whole insert comment so everything looks crunch up. Is there way to auto format just the length of the insert comment?

.AutoSize = True

.AddComment "Part" & Space(lngcelllen - 2) & "QTY" & mptemp
With .Comment.Shape.TextFrame
.Characters(1, 4).Font.Bold = True
.Characters(lngcelllen + 3, 3).Font.Bold = True
.HorizontalAlignment = xlHAlignDistributed
.VerticalAlignment = xlVAlignJustify
End With
End With

[Shazam]

I was playing around with the code and I finally I got the way I wanted. These are the lines I modified and works great. Thank you rory and xld for all your help.

.AddComment "Part " & Space(lngcelllen - 2) & "QTY" & mptemp

.Characters(lngcelllen + 3, 15).Font.Bold = True


The final version I'm using.

Sub Test()
Dim mpCell As Range, rngCheck As Range
Dim mptemp As String, lngcelllen As Long, lngindex As Long
Dim varData
With Worksheets("Range")
Set rngCheck = .Range(.Range("A2:B2"), .Range("A2").End(xlDown))
For Each mpCell In rngCheck
If lngcelllen < Len(mpCell.Text) Then lngcelllen = Len(mpCell.Text)
Next mpCell
End With
varData = rngCheck
For lngindex = 1 To UBound(varData, 1)
mptemp = mptemp & vbLf & varData(lngindex, 1) & Space(lngcelllen + 2 - Len(varData(lngindex, 1))) & varData(lngindex, 2)
Next lngindex
With Worksheets("Expected Results").Range("A2")
On Error Resume Next
.Comment.Delete
On Error GoTo 0
.AddComment "Part " & Space(lngcelllen - 2) & "QTY" & mptemp
With .Comment.Shape.TextFrame
.Characters(1, 4).Font.Bold = True
.Characters(lngcelllen + 3, 15).Font.Bold = True
.HorizontalAlignment = xlHAlignDistributed
.VerticalAlignment = xlVAlignJustify
.AutoSize = True
End With
End With

End Sub


Once again thank you all.