A query in continuation to the nested bordering - To TOM, JIM and others....

T

Thulasiram

Tom, Jim and other experts with VB,

Given below is the code (written by Tom) that highlights the area of
intersection of two cells (merged or single).

For example, if the merged cells B4 (formed by merging B4 to B9) and H2
(formed by merging H2 to L2) are clicked, then the higlighted area with
boundary is H4-H9; H9-L9; L9-L4; L4-H4.

As a step ahead, along with the border highlighting, is it possible to
collapse all the cells in the boundary into a single cell that shows
the SUM of the elements in it...? If yes, please help me.

In lines of the example discussed above, is it possible to show the sum
of H4-H9; H9-L9; L9-L4; L4-H4 in a single cell inside that boundary? I
tried recording macro. It was not generic. Moreover, it did not yield
the required results.

Please help.

Thanks,
Thulasiram.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Areas.Count = 2 Then
OutlineSelectedAreas Target.Areas(1), Target.Areas(2)
End If
End Sub

Function OutlineSelectedAreas(ByRef Rng1 As Excel.Range, _
ByRef Rng2 As Excel.Range)
Dim Rng3 As Excel.Range
' Dim lngRow As Long
' Dim lngCol As Long
' Dim lngLastRow As Long
' Dim lngLastCol As Long
With Cells
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With


' lngRow = Application.Min(Rng1.Row, Rng2.Row)
' lngCol = Application.Min(Rng1.Column, Rng2.Column)
' lngLastRow = Application.Max(Rng1.Rows(Rng1.Rows.Count).Row, _
Rng2.Rows(Rng2.Rows.Count).Row)
' lngLastCol =
Application.Max(Rng1.Columns(Rng1.Columns.Count).Column, _
Rng2.Columns(Rng2.Columns.Count).Column)

' Set Rng3 = Range(Cells(lngRow, lngCol), Cells(lngLastRow,
lngLastCol))
If Rng1.Column = Rng2.Column Then
If Rng1.Row < Rng2.Row Then
Set rngTmp = Rng1
Set Rng1 = Rng2
Set Rng2 = rngTmp
End If
ElseIf Rng1.Column > Rng2.Column Then
Set rngTmp = Rng1
Set Rng1 = Rng2
Set Rng2 = rngTmp
End If
Set Rng3 = Intersect(Rng1.EntireRow, Rng2.EntireColumn)
Rng1.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
Rng2.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
Rng3.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
Set Rng1 = Nothing
Set Rng2 = Nothing
Set Rng3 = Nothing
End Function
 
B

Bob Phillips

Add this line


Range("A1").Value = Application.Sum(Rng3)

just before the last 3 lines in the function, the Set ... = Nothing lines.

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)
 
T

Thulasiram

Dear Bob,

It works! Also, I have implemented another line that higlights the rng3
with a colorindex.

Is it possible to merge all the cells in the Rng3 into a single cell
and display only the sum in it?

Please help

Thanks,
Thulasiram.
 
T

Thulasiram

Dear Bob,

This is in continuation with my previous post in this topic: I solved
part of my question in the previous topic but still struggling with the
later part of the question.

I have merged the cells using Rng3.merge as shown below.

But when this operation is performed, then Excel gives a message that
only the top value of the cell will be present after the cells are
merged. Is there any way to have the sum of rng3 (aligned in the middle
of the merged cell) after the cells are merged?

Please help

Set Rng3 = Intersect(Rng1.EntireRow, Rng2.EntireColumn)
Rng1.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
Rng2.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
Rng3.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
Rng3.Interior.ColorIndex = 6
Range("A1").Value = Application.Sum(Rng3)
Rng3.Merge

Thanks,
Thulasiram
 
B

Bob Phillips

Function OutlineSelectedAreas(ByRef Rng1 As Excel.Range, _
ByRef Rng2 As Excel.Range)
Dim Rng3 As Excel.Range
Dim RngTmp As Range
' Dim lngRow As Long
' Dim lngCol As Long
' Dim lngLastRow As Long
' Dim lngLastCol As Long
With Cells
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With

If Rng1.Column = Rng2.Column Then
If Rng1.Row < Rng2.Row Then
Set RngTmp = Rng1
Set Rng1 = Rng2
Set Rng2 = RngTmp
End If
ElseIf Rng1.Column > Rng2.Column Then
Set RngTmp = Rng1
Set Rng1 = Rng2
Set Rng2 = RngTmp
End If
Set Rng3 = Intersect(Rng1.EntireRow, Rng2.EntireColumn)
Rng1.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
Rng2.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
Application.DisplayAlerts = False
With Rng3
.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
.Interior.ColorIndex = 6
.Value = Application.Sum(Rng3)
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Application.DisplayAlerts = True

Set Rng1 = Nothing
Set Rng2 = Nothing
Set Rng3 = Nothing
End Function


--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)
 
T

Thulasiram

Thanks a ton Mr.Bob

You have solved my six hour try on this situation.

Thanks again,
Thulasiram
 
T

Thulasiram

Dear Mr.Bob,

The code works perfectly for intersection of the selected cells.

Now, I am trying to select only a single cell (instead of two cells).
Result should be a higlighted boundary for all the cells corresponding
to that selected merged cell. I have modified the code to suit this
condition. But the result is eratic.

Please help

Modified code for this single cell selection and the original code for
two cell selection are given below:

If Target.Areas.Count = 1 Then
' OutlineSelectedAreas2 Target.Areas(1), Target.Areas(2)
OutlineSelectedAreas3 Target.Areas(1)
End If

Function OutlineSelectedAreas3(ByRef Rng1 As Excel.Range)
' code for entirerow condition

Dim Rng3 As Excel.Range
Dim RngTmp As Range
'**********for one click*********************
' Dim lngRow As Long
' Dim lngCol As Long
' Dim lngLastRow As Long
' Dim lngLastCol As Long
With Cells
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
.Interior.ColorIndex = 0
End With

' If Rng1.Column = Rng2.Column Then
' If Rng1.Row < Rng2.Row Then
' Set RngTmp = Rng1
' Set Rng1 = Rng2
' Set Rng2 = RngTmp
' End If
'ElseIf Rng1.Column > Rng2.Column Then
' Set RngTmp = Rng1
' Set Rng1 = Rng2
' Set Rng2 = RngTmp
'End If
'Set Rng3 = Intersect(Rng1.EntireRow, Rng2.EntireColumn)
Set Rng1 = RngTmp
Set Rng3 = Rng1.EntireRow
Rng1.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
'Rng2.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
Application.DisplayAlerts = False
With Rng3
.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
.Interior.ColorIndex = 6
.Value = Application.Sum(Rng3)
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Application.DisplayAlerts = True

Set Rng1 = Nothing
'Set Rng2 = Nothing
Set Rng3 = Nothing
End Function

************* code for 2 cells selection ***************

Function OutlineSelectedAreas(ByRef Rng1 As Excel.Range, _
ByRef Rng2 As Excel.Range)
Dim Rng3 As Excel.Range
Dim RngTmp As Range
' Dim lngRow As Long
' Dim lngCol As Long
' Dim lngLastRow As Long
' Dim lngLastCol As Long
With Cells
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With

If Rng1.Column = Rng2.Column Then
If Rng1.Row < Rng2.Row Then
Set RngTmp = Rng1
Set Rng1 = Rng2
Set Rng2 = RngTmp
End If
ElseIf Rng1.Column > Rng2.Column Then
Set RngTmp = Rng1
Set Rng1 = Rng2
Set Rng2 = RngTmp
End If
Set Rng3 = Intersect(Rng1.EntireRow, Rng2.EntireColumn)
Rng1.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
Rng2.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
Application.DisplayAlerts = False
With Rng3
.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
.Interior.ColorIndex = 6
.Value = Application.Sum(Rng3)
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Application.DisplayAlerts = True

Set Rng1 = Nothing
Set Rng2 = Nothing
Set Rng3 = Nothing
End Function
 
T

Thulasiram

Dear Mr.Bob,

I am sure that this would be the last query I would have as far this
bordering issue is concerned.

I have been breaking my head with this for past 36 hours trying to
figure out a way to solve my objective. With your help I am progressing
well but still landing into quite a lot of problems.

Just a minor mofication to the original problem statement.

Code below gives the resultant rng3 in the same worksheet. Assuming
that there are two identical sheets, I have a query pertaining to this.

Instead of displaying the result of Rng3 operations in the same
worksheet, is it possible to display it in the next worksheet?
For example, user selects two cells in sheet1 and the result (includes
merging, adding, color coding), instead of being displayed in the same
sheet, should be displayed in the next sheet (sheet2).

Thanks for all your help.
Sincerely,
Thulasiram

Code:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Areas.Count = 2 Then
OutlineSelectedAreas2 Target.Areas(1), Target.Areas(2)
End If
End Sub

Function OutlineSelectedAreas(ByRef Rng1 As Excel.Range, _
ByRef Rng2 As Excel.Range)
Dim Rng3 As Excel.Range
Dim RngTmp As Range
' Dim lngRow As Long
' Dim lngCol As Long
' Dim lngLastRow As Long
' Dim lngLastCol As Long
With Cells
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With

If Rng1.Column = Rng2.Column Then
If Rng1.Row < Rng2.Row Then
Set RngTmp = Rng1
Set Rng1 = Rng2
Set Rng2 = RngTmp
End If
ElseIf Rng1.Column > Rng2.Column Then
Set RngTmp = Rng1
Set Rng1 = Rng2
Set Rng2 = RngTmp
End If
Set Rng3 = Intersect(Rng1.EntireRow, Rng2.EntireColumn)
Rng1.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
Rng2.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
Application.DisplayAlerts = False
With Rng3
.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
.Interior.ColorIndex = 6
.Value = Application.Sum(Rng3)
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Application.DisplayAlerts = True

Set Rng1 = Nothing
Set Rng2 = Nothing
Set Rng3 = Nothing
End Function
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Locate non-blanks in a column and copy certain data from the row 1
add a chart in a Add-In 1
Coding to choose the previous completed cell in a column 5
How to get each table's first line of record and write into excel? 3
A MACRO TO BUILD BORDERS 6
Looping through Query to create multiple sheets in excel- Just need the loop 2

Top