I am seeking help designing function or macros that will perform the following task:

Allow a user to select a specific base model non living quarter trailer and have a function input the price in the blank cell under list price. I would like this to be as simple for the user as possible. I would like the user to click on the corresponding cell to whatever trailer that they desire, and have the function or macro input directly into the blue cells near the bottom of the page. If anybody that can come up with something that would work to complete this task, that would be great. If you need more information, just let me know.

Thanks

On Wed, 31 Jul 2013 14:34:39 +0100, smoborny wrote:


I am seeking help designing function or macros that will perform the
following task:

Allow a user to select a specific base model non living quarter trailer
and have a function input the price in the blank cell under list price.
I would like this to be as simple for the user as possible. I would like
the user to click on the corresponding cell to whatever trailer that
they desire, and have the function or macro input directly into the blue
cells near the bottom of the page. If anybody that can come up with
something that would work to complete this task, that would be great. If
you need more information, just let me know.

Thanks


+-------------------------------------------------------------------+
|Filename: excelbanter.jpg |
|Download: http://www.excelbanter.com/attachment.php?attachmentid=893|
+-------------------------------------------------------------------+

Suggest you post a workbook, with the data entered, rather than a picture. For those of us who want to respond, it would sure save us some time as we would not have to generate the workbook.

Here you go, thanks for your suggestion

On Wed, 31 Jul 2013 19:25:19 +0100, smoborny wrote:


Here you go, thanks for your suggestion


+-------------------------------------------------------------------+
|Filename: Book1.zip |
|Download: http://www.excelbanter.com/attachment.php?attachmentid=895|
+-------------------------------------------------------------------+

If your real data layout is pretty close to what you've posted, the following Event Macro should do what you want.

To enter this event-triggered Macro, right click on the sheet tab.
Select "View Code" from the right-click drop-down menu.
Then paste the code below into the window that opens.


=====================================
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Range
Dim rTS As Range
Dim rPrice As Range
Dim s As String, cost As Double

Set r = Range("a1", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=10)
If Not Intersect(Target, r) Is Nothing Then
Set rTS = Cells.Find(what:="TRAILER SHELL (NO LQ)", after:=[a1], _
LookIn:=xlValues, lookat:=xlPart, searchdirection:=xlNext, _
MatchCase:=True)
Set rPrice = Cells.Find(what:="List", after:=rTS, searchorder:=xlByRows)
If rTS Is Nothing Or rPrice Is Nothing Then
MsgBox ("No place for results")
Exit Sub
End If
Set rTS = rTS.Offset(rowoffset:=1)
Set rPrice = rPrice.Offset(rowoffset:=1)
If IsNumeric(Target) And Len(Target) 0 Then
cost = Target.Value
s = Cells(Target.Row, "A").Text & ", " & _
Target.End(xlUp).Text & ", " & _
Cells(Target.End(xlUp).Row - 1, "A").Text
End If
rTS = s
rPrice = cost
rPrice.NumberFormat = "$#,##0"
End If
End Sub
===========================================

On Wed, 31 Jul 2013 19:25:19 +0100, smoborny wrote:


Here you go, thanks for your suggestion


+-------------------------------------------------------------------+
|Filename: Book1.zip |
|Download: http://www.excelbanter.com/attachment.php?attachmentid=895|
+-------------------------------------------------------------------+

Looking also at your "picture" where you indicate more clearly how you want the Trailer Shell data entered, I made some changes to the VBA Code in my previous post:

==================================
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Range
Dim rTS As Range
Dim rPrice As Range
Dim s As String, cost As Double

Application.EnableEvents = False
Set r = Range("a1", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=10)
Set r = r.SpecialCells(xlCellTypeConstants, xlNumbers)

If Not Intersect(Target, r) Is Nothing Then
Set rTS = Cells.Find(what:="TRAILER SHELL (NO LQ)", after:=[a1], _
LookIn:=xlValues, lookat:=xlPart, searchdirection:=xlNext, _
MatchCase:=True)
Set rPrice = Cells.Find(what:="List", after:=rTS, searchorder:=xlByRows)
If rTS Is Nothing Or rPrice Is Nothing Then
MsgBox ("No place for results")
Exit Sub
End If
Set rTS = rTS.Offset(rowoffset:=1)
Set rPrice = rPrice.Offset(rowoffset:=1)
cost = Target.Value
s = Replace(Cells(Target.End(xlUp).Row - 1, "A").Text, "/", " x ") & _
" / " & Cells(Target.Row, "A").Text & " / " & _
Target.End(xlUp).Text & " Short Wall"
rTS = s
rPrice = cost
rPrice.NumberFormat = "$#,##0"
End If
Application.EnableEvents = True
End Sub
===========================================

I am impressed, thanks for such a quick response! Now I am in the process of allowing the code to work in my complete project. I have been attempting this for a couple hours and haven't got anywhere. If the prices you seen on the zip file that I uploaded were referenced back to a different workbook would I have to change the code?

Just curious if you could post a description of what is being accomplished next to each line of code, so I can understand it better. I am going to have to use this code in other projects and I would like to be able to do it myself. Thanks in advance!

Once again great job on designing that macro. All I need now is for it to function with 3 different "tables" on the same sheet. Here is what I am working with

On Thu, 1 Aug 2013 17:38:10 +0100, smoborny wrote:


Just curious if you could post a description of what is being
accomplished next to each line of code, so I can understand it better. I
am going to have to use this code in other projects and I would like to
be able to do it myself. Thanks in advance!


+-------------------------------------------------------------------+
+-------------------------------------------------------------------+

Here is the code with some explanation -- not always "next to", but you should be able to figure it out.

On Thu, 1 Aug 2013 16:30:06 +0100, smoborny wrote:


I am impressed, thanks for such a quick response! Now I am in the
process of allowing the code to work in my complete project. I have been
attempting this for a couple hours and haven't got anywhere. If the
prices you seen on the zip file that I uploaded were referenced back to
a different workbook would I have to change the code?


I don't know what you mean by "referenced back to a different workbook"
But if the cells showing the prices really contain a formula, rather than a number as shown in the worksheet you sent, then the code would need to be changed.

On Thu, 1 Aug 2013 23:14:52 +0100, smoborny wrote:


Once again great job on designing that macro. All I need now is for it
to function with 3 different "tables" on the same sheet. Here is what I
am working with


+-------------------------------------------------------------------+
|Filename: Book1.zip |
|Download: http://www.excelbanter.com/attachment.php?attachmentid=897|
+-------------------------------------------------------------------+

In Sheet1!X32 you show "8' WIDE x 7'6" TALL / 5 Horse / 10' Short Wall"

Is that correct or not. I would have thought it should show "LIVING QUARTER TRAILER W/ SLIDE OUT - LIST PRICE"

Also, you will need to save your file as .xlsm or .xlsb. .xlsx will not allow a macro to run

Thank you for all the time you are spending on this and for the tips! Just curious if you forgot the attachment on one of your previous posts. you are also correct that cell was suppose to say "LIVING QUARTER TRAILER W/ SLIDE OUT - LIST PRICE"

On Fri, 2 Aug 2013 15:27:20 +0100, smoborny wrote:


Thank you for all the time you are spending on this and for the tips!
Just curious if you forgot the attachment on one of your previous posts.
you are also correct that cell was suppose to say "LIVING QUARTER
TRAILER W/ SLIDE OUT - LIST PRICE"


+-------------------------------------------------------------------+
+-------------------------------------------------------------------+

Try this macro, entered the same way after selecting the sheet tab and selecting "View Code"

The complexity is required because of your layout.

=============================================
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rTbl() As Range
Dim c As Range, r As Range
Dim sTblHeader() As String
Dim i As Long, j As Long
Dim lFirstRow As Long
Dim lLastRow As Long
Dim lLastCol As Long
'Get Table Headers and cells
Application.EnableEvents = False
Set r = Range("A1", Cells(1, Columns.Count).End(xlToLeft))
i = WorksheetFunction.CountA(r)
ReDim rTbl(1 To i, 0 To 2) 'dim 1 is table, 2 is TS text, 3 is List
ReDim sTblHeader(1 To i, 0 To 1) 'dimension 1 is text, 2 is address
For Each c In r
If Len(c.Text) 0 Then
j = j + 1
sTblHeader(j, 0) = c.Text
sTblHeader(j, 1) = c.Address
End If
Next c

For i = 1 To UBound(sTblHeader) 'iterate for each table
'get first row of table
With Cells
Set c = .Find(what:="Horse", after:=Range(sTblHeader(i, 1)), LookIn:=xlValues, _
lookat:=xlPart, searchdirection:=xlNext, searchorder:=xlByColumns, _
MatchCase:=True)
lFirstRow = c.Row
lLastCol = c.End(xlToRight).Column
Set c = .Find(what:="Horse", after:=Cells(Rows.Count, c.Column), searchdirection:=xlPrevious)
lLastRow = c.Row

'If all of the Prices are formed by functions/formulas, then change xlCellTypeConstants to xlCellTypeFormulas
' in the line below. Leave everything else the same

Set rTbl(i, 0) = Range(Cells(lFirstRow, c.Column + 1), Cells(lLastRow, lLastCol)).SpecialCells(xlCellTypeConstants, xlNumbers)

Set c = .Find(what:=Trim(Left(sTblHeader(i, 0), InStr(sTblHeader(i, 0), "-") - 1)), after:=c, _
LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlNext)
Set rTbl(i, 1) = c.Offset(rowoffset:=1) 'Trailer Text
Set rTbl(i, 2) = c.Offset(rowoffset:=1, columnoffset:=1) 'List Price

End With
Next i

For i = 1 To UBound(rTbl)
If Not Intersect(Target, rTbl(i, 0)) Is Nothing Then
rTbl(i, 1) = Replace(Cells(Target.End(xlUp).Row - 1, Target.End(xlToLeft).Column).Text, "/", " x ") & _
" / " & Target.End(xlToLeft).Text & " / " & _
Target.End(xlUp).Text & " Short Wall"
rTbl(i, 1).ShrinkToFit = True
rTbl(i, 2) = Target.Value
rTbl(i, 2).NumberFormat = "$#,##0"
End If
Next i
Application.EnableEvents = True
End Sub
=================================================

On Fri, 2 Aug 2013 15:27:20 +0100, smoborny wrote:


Thank you for all the time you are spending on this and for the tips!
Just curious if you forgot the attachment on one of your previous posts.
you are also correct that cell was suppose to say "LIVING QUARTER
TRAILER W/ SLIDE OUT - LIST PRICE"


+-------------------------------------------------------------------+
+-------------------------------------------------------------------+

And here is the forgotten attachment. This will NOT work on your current data, but it is annotated.

=============================
Option Explicit
'triggers when a new cell is selected on this worksheet
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Target is the cell that has just been selected
Dim r As Range
Dim rTS As Range 'tractor shell data will be copied here
Dim rPrice As Range 'price data will be copied here
Dim s As String, cost As Double

Application.EnableEvents = False 'don't trigger on any more changes
Set r = Range("a1", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=10)
' r is set to all the rows in column A for row 1 to the last row used
'this is good since the Trailer shell at the bottom does not occupy anything in column A

Set r = r.SpecialCells(xlCellTypeConstants, xlNumbers)
'refines r to only refer to cells with numbers in them. This will be the
' price cells in the table

If Not Intersect(Target, r) Is Nothing Then 'Is target in one of the 'r' cells?
'yes, so do the following:
Set rTS = Cells.Find(what:="TRAILER SHELL (NO LQ)", after:=[a1], _
LookIn:=xlValues, lookat:=xlPart, searchdirection:=xlNext, _
MatchCase:=True) 'cell to copy trailer shell stuff
Set rPrice = Cells.Find(what:="List", after:=rTS, searchorder:=xlByRows)
'cell to copy Price data

If rTS Is Nothing Or rPrice Is Nothing Then 'check that the rTS and rPrice cells exist
MsgBox ("No place for results")
Exit Sub
End If
Set rTS = rTS.Offset(rowoffset:=1) 'rTS should be one row below the cell containing the phrase "TRAILER SHELL (NO LQ)"
Set rPrice = rPrice.Offset(rowoffset:=1) 'rPrice should be one row below the cell containing the word "List"
cost = Target.Value 'Target was the selected cell which contains the price


'Line 1 below: from Target, up-arrow gets to short wall information; up one more row
' and in column A gets to Wide x Tall data
' need to replace the "/" with a " x " to meet your specs
'Line 2 below: same row as Target in column A contains the n Horses data
s = Replace(Cells(Target.End(xlUp).Row - 1, "A").Text, "/", " x ") & _
" / " & Cells(Target.Row, "A").Text & " / " & _
Target.End(xlUp).Text & " Short Wall"
rTS = s
rPrice = cost
rPrice.NumberFormat = "$#,##0"
End If
Application.EnableEvents = True
End Sub
===========================================

Try this macro, entered the same way after selecting the sheet tab and selecting "View Code"

The complexity is required because of your layout.

=============================================
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rTbl() As Range
Dim c As Range, r As Range
Dim sTblHeader() As String
Dim i As Long, j As Long
Dim lFirstRow As Long
Dim lLastRow As Long
Dim lLastCol As Long
'Get Table Headers and cells
Application.EnableEvents = False
Set r = Range("A1", Cells(1, Columns.Count).End(xlToLeft))
i = WorksheetFunction.CountA(r)
ReDim rTbl(1 To i, 0 To 2) 'dim 1 is table, 2 is TS text, 3 is List
ReDim sTblHeader(1 To i, 0 To 1) 'dimension 1 is text, 2 is address
For Each c In r
If Len(c.Text) 0 Then
j = j + 1
sTblHeader(j, 0) = c.Text
sTblHeader(j, 1) = c.Address
End If
Next c

For i = 1 To UBound(sTblHeader) 'iterate for each table
'get first row of table
With Cells
Set c = .Find(what:="Horse", after:=Range(sTblHeader(i, 1)), LookIn:=xlValues, _
lookat:=xlPart, searchdirection:=xlNext, searchorder:=xlByColumns, _
MatchCase:=True)
lFirstRow = c.Row
lLastCol = c.End(xlToRight).Column
Set c = .Find(what:="Horse", after:=Cells(Rows.Count, c.Column), searchdirection:=xlPrevious)
lLastRow = c.Row

'If all of the Prices are formed by functions/formulas, then change xlCellTypeConstants to xlCellTypeFormulas
' in the line below. Leave everything else the same

Set rTbl(i, 0) = Range(Cells(lFirstRow, c.Column + 1), Cells(lLastRow, lLastCol)).SpecialCells(xlCellTypeConstants, xlNumbers)

Set c = .Find(what:=Trim(Left(sTblHeader(i, 0), InStr(sTblHeader(i, 0), "-") - 1)), after:=c, _
LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlNext)
Set rTbl(i, 1) = c.Offset(rowoffset:=1) 'Trailer Text
Set rTbl(i, 2) = c.Offset(rowoffset:=1, columnoffset:=1) 'List Price

End With
Next i

For i = 1 To UBound(rTbl)
If Not Intersect(Target, rTbl(i, 0)) Is Nothing Then
rTbl(i, 1) = Replace(Cells(Target.End(xlUp).Row - 1, Target.End(xlToLeft).Column).Text, "/", " x ") & _
" / " & Target.End(xlToLeft).Text & " / " & _
Target.End(xlUp).Text & " Short Wall"
rTbl(i, 1).ShrinkToFit = True
rTbl(i, 2) = Target.Value
rTbl(i, 2).NumberFormat = "$#,##0"
End If
Next i
Application.EnableEvents = True
End Sub
=================================================[/quote]

Very good! works just as I was imagining! I am very impressed! What variables would I have to change if I added information preceding the cost tables? Say the charts would start at CH3. Thanks again, you are a life saver

Also just curious if there was a way to make the macro input only the most current selection into the corresponding cell, and eliminate the previous inputs. For Example, if I clicked for a 7'2" wide 7' tall / 2 Horse / 4'5" Short Wall under "Trailer Shell (No LQ)" -- the macro inputs the corresponding information directly below the Trailer shell no lq and list price -- (we will call this step A) then say I clicked on the 7'2" WIDE / 7' Tall / 6 Horse / 4'5" Short Wall under "Living Quarter Trailer" --the macro inputs the corresponding information directly below the Living Quarter trailer and list price -- (we will call this step B) ((At this time there are 2 different models displayed at the bottom, I would like for there to be only the most current selection.)) I would like for the macro to remove the previous input and only display the most current selection. In other words if I completed step A and B, the macro would only display the results of step B.

On Mon, 5 Aug 2013 17:07:31 +0100, smoborny wrote:


Also just curious if there was a way to make the macro input only the
most current selection into the corresponding cell, and eliminate the
previous inputs. For Example, if I clicked for a 7'2" wide 7' tall / 2
Horse / 4'5" Short Wall under "Trailer Shell (No LQ)" -- the macro
inputs the corresponding information directly below the Trailer shell no
lq and list price -- (we will call this step A) then say I clicked on
the 7'2" WIDE / 7' Tall / 6 Horse / 4'5" Short Wall under "Living
Quarter Trailer" --the macro inputs the corresponding information
directly below the Living Quarter trailer and list price -- (we will
call this step B) ((At this time there are 2 different models displayed
at the bottom, I would like for there to be only the most current
selection.)) I would like for the macro to remove the previous input and
only display the most current selection. In other words if I completed
step A and B, the macro would only display the results of step B.


+-------------------------------------------------------------------+
+-------------------------------------------------------------------+

Try this:

===================================
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rTbl() As Range
Dim c As Range, r As Range
Dim sTblHeader() As String
Dim i As Long, j As Long
Dim lFirstRow As Long
Dim lLastRow As Long
Dim lLastCol As Long
'Get Table Headers and cells
Application.EnableEvents = False
Set r = Range("A1", Cells(1, Columns.Count).End(xlToLeft))
i = WorksheetFunction.CountA(r)
ReDim rTbl(1 To i, 0 To 2) 'dim 1 is table, 2 is TS text, 3 is List
ReDim sTblHeader(1 To i, 0 To 1) 'dimension 1 is text, 2 is address
For Each c In r
If Len(c.Text) 0 Then
j = j + 1
sTblHeader(j, 0) = c.Text
sTblHeader(j, 1) = c.Address
End If
Next c

For i = 1 To UBound(sTblHeader) 'iterate for each table
'get first row of table
With Cells
Set c = .Find(what:="Horse", after:=Range(sTblHeader(i, 1)), LookIn:=xlValues, _
lookat:=xlPart, searchdirection:=xlNext, searchorder:=xlByColumns, _
MatchCase:=True)
lFirstRow = c.Row
lLastCol = c.End(xlToRight).Column
Set c = .Find(what:="Horse", after:=Cells(Rows.Count, c.Column), searchdirection:=xlPrevious)
lLastRow = c.Row

'If all of the Prices are formed by functions/formulas, then change xlCellTypeConstants to xlCellTypeFormulas
' in the line below. Leave everything else the same

Set rTbl(i, 0) = Range(Cells(lFirstRow, c.Column + 1), Cells(lLastRow, lLastCol)).SpecialCells(xlCellTypeConstants, xlNumbers)

Set c = .Find(what:=Trim(Left(sTblHeader(i, 0), InStr(sTblHeader(i, 0), "-") - 1)), after:=c, _
LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlNext)
Set rTbl(i, 1) = c.Offset(rowoffset:=1) 'Trailer Text
Set rTbl(i, 2) = c.Offset(rowoffset:=1, columnoffset:=1) 'List Price

End With
Next i

For i = 1 To UBound(rTbl)
If Not Intersect(Target, rTbl(i, 0)) Is Nothing Then
rTbl(i, 1) = Replace(Cells(Target.End(xlUp).Row - 1, Target.End(xlToLeft).Column).Text, "/", " x ", 1, 1) & _
" / " & Target.End(xlToLeft).Text & " / " & _
Target.End(xlUp).Text & " Short Wall"
rTbl(i, 1).ShrinkToFit = True
rTbl(i, 2) = Target.Value
rTbl(i, 2).NumberFormat = "$#,##0"

'clear other entries
For j = 1 To UBound(rTbl)
If j < i Then
rTbl(j, 1).MergeArea.ClearContents
rTbl(j, 2).ClearContents
End If
Next j

End If
Next i
Application.EnableEvents = True
End Sub
=====================================

On Mon, 5 Aug 2013 16:15:26 +0100, smoborny wrote:

Very good! works just as I was imagining! I am very impressed! What
variables would I have to change if I added information preceding the cost
tables? Say the charts would start at CH3. Thanks again, you are a life
saver

If what you did is move the entire block of data that you presented previously, to start at CH3, and there is nothing either below or to the right of the table, then the only thing you need to change is the line that sets r to the data range.


Current:
Set r = Range("A1", Cells(1, Columns.Count).End(xlToLeft))

Change to
Set r = Range("CH3", Cells(3, Columns.Count).End(xlToLeft))

You are changing both the first cell from A1 to CH3, and also the first row (in the second Range argument) from 1 to 3.

Unfortunately I have data to the right of the block of data we have been working with. I assume this will mess with the current .end(xlToLeft) . Thanks again for your time and patience, I am a novice with an interest in writing user defined functions.

On Tue, 6 Aug 2013 14:18:22 +0100, smoborny wrote:

Unfortunately I have data to the right of the block of data we have been
working with. I assume this will mess with the current .end(xlToLeft) .
Thanks again for your time and patience, I am a novice with an interest
in writing user defined functions.


You should take note of the fact that incomplete and incorrect descriptions of your data, problems, etc will often lead to solutions that work perfectly OK on what you show, but won't work on what you really have.
You should take the time to present an accurate synopsis of your actual data, problem, and desired results, rather than hoping that, by taking shortcuts, solutions will be quicker.

When you get around to it, try to present a more realistic set of data.

On Tue, 6 Aug 2013 14:18:22 +0100, smoborny wrote:

Unfortunately I have data to the right of the block of data we have been
working with. I assume this will mess with the current .end(xlToLeft) .
Thanks again for your time and patience, I am a novice with an interest
in writing user defined functions.

Also, If your data to the right is not in Row 3, than the macro will work as designed, otherwise it will need to be modified.

On Tue, 6 Aug 2013 14:18:22 +0100, smoborny wrote:

Unfortunately I have data to the right of the block of data we have been
working with. I assume this will mess with the current .end(xlToLeft) .
Thanks again for your time and patience, I am a novice with an interest
in writing user defined functions.

Hopefully, this will work. It depends on identifying the tables as having the only entries in Row 3 that have the substring "- LIST PRICE", and that the heading is merged across a group of cells as is the case in your last examples:

======================================
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rTbl() As Range
Dim c As Range, R As Range
Dim sTblHeader() As String
Dim i As Long, j As Long
Dim lFirstRow As Long
Dim lLastRow As Long
Dim lLastCol As Long
Dim sFirstAddress As String

'Get Table Headers and cells
Application.EnableEvents = False
With Rows(3)
Set R = .Find(what:=" - LIST PRICE", after:=.Cells(1), LookIn:=xlValues, lookat:=xlPart, _
searchorder:=xlByColumns, searchdirection:=xlNext, MatchCase:=True)
sFirstAddress = R.Address
i = 1
Do
Set R = .FindNext(R)
If R.Address < sFirstAddress Then
lLastCol = R(columnindex:=R.MergeArea.Columns.Count).Column
i = i + 1
End If
Loop Until R.Address = sFirstAddress
End With

Set R = Range(R, Cells(R.Row, lLastCol))

ReDim rTbl(1 To i, 0 To 2) 'dim 1 is table, 2 is TS text, 3 is List
ReDim sTblHeader(1 To i, 0 To 1) 'dimension 1 is text, 2 is address
For Each c In R
If Len(c.Text) 0 Then
j = j + 1
sTblHeader(j, 0) = c.Text
sTblHeader(j, 1) = c.Address
End If
Next c

For i = 1 To UBound(sTblHeader) 'iterate for each table
'get first row of table
With Cells
Set c = .Find(what:="Horse", after:=Range(sTblHeader(i, 1)), LookIn:=xlValues, _
lookat:=xlPart, searchdirection:=xlNext, searchorder:=xlByColumns, _
MatchCase:=True)
lFirstRow = c.Row
lLastCol = c.End(xlToRight).Column
Set c = .Find(what:="Horse", after:=Cells(Rows.Count, c.Column), searchdirection:=xlPrevious)
lLastRow = c.Row

'If all of the Prices are formed by functions/formulas, then change xlCellTypeConstants to xlCellTypeFormulas
' in the line below. Leave everything else the same

Set rTbl(i, 0) = Range(Cells(lFirstRow, c.Column + 1), Cells(lLastRow, lLastCol)).SpecialCells(xlCellTypeConstants, xlNumbers)

Set c = .Find(what:=Trim(Left(sTblHeader(i, 0), InStr(sTblHeader(i, 0), "-") - 1)), after:=c, _
LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlNext)
Set rTbl(i, 1) = c.Offset(rowoffset:=1) 'Trailer Text
Set rTbl(i, 2) = c.Offset(rowoffset:=1, columnoffset:=1) 'List Price

End With
Next i

For i = 1 To UBound(rTbl)
If Not Intersect(Target, rTbl(i, 0)) Is Nothing Then
rTbl(i, 1) = Replace(Cells(Target.End(xlUp).Row - 1, Target.End(xlToLeft).Column).Text, "/", " x ", 1, 1) & _
" / " & Target.End(xlToLeft).Text & " / " & _
Target.End(xlUp).Text & " Short Wall"
rTbl(i, 1).ShrinkToFit = True
rTbl(i, 2) = Target.Value
rTbl(i, 2).NumberFormat = "$#,##0"

'clear other entries
For j = 1 To UBound(rTbl)
If j < i Then
rTbl(j, 1).MergeArea.ClearContents
rTbl(j, 2).ClearContents
End If
Next j

End If
Next i
Application.EnableEvents = True
End Sub
========================================

WOW! Works Great! You did a great job at listening for what I wanted and getting it back to me in reasonable time. I am now wanting to be able to protect the worksheet and still have the functions continue to work. I have protected the sheet and unlocked the protection for all cells with a price in it, and I still get an error. What must I change in the code to allow it to still function on a protected sheet?

On Wed, 7 Aug 2013 14:29:07 +0100, smoborny wrote:


WOW! Works Great! You did a great job at listening for what I wanted and
getting it back to me in reasonable time. I am now wanting to be able to
protect the worksheet and still have the functions continue to work. I
have protected the sheet and unlocked the protection for all cells with
a price in it, and I still get an error. What must I change in the code
to allow it to still function on a protected sheet?


+-------------------------------------------------------------------+
+-------------------------------------------------------------------+

What is the error?

On Wed, 7 Aug 2013 14:29:07 +0100, smoborny wrote:


WOW! Works Great! You did a great job at listening for what I wanted and
getting it back to me in reasonable time. I am now wanting to be able to
protect the worksheet and still have the functions continue to work. I
have protected the sheet and unlocked the protection for all cells with
a price in it, and I still get an error. What must I change in the code
to allow it to still function on a protected sheet?


+-------------------------------------------------------------------+
+-------------------------------------------------------------------+

What is the error?
Most likely, you could just add Protect and UnProtect statements in the code.
Also, unless you are going to allow the users to alter the prices, there is no reason to UNLOCK those cells. Merely enable protection but allow the users to select Locked Cells.

=============================================
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rTbl() As Range
Dim c As Range, R As Range
Dim sTblHeader() As String
Dim i As Long, j As Long
Dim lFirstRow As Long
Dim lLastRow As Long
Dim lLastCol As Long
Dim sFirstAddress As String

ActiveSheet.Unprotect
On Error GoTo ExitPoint
'Get Table Headers and cells
Application.EnableEvents = False
With Rows(3)
Set R = .Find(what:=" - LIST PRICE", after:=.Cells(1), LookIn:=xlValues, lookat:=xlPart, _
searchorder:=xlByColumns, searchdirection:=xlNext, MatchCase:=True)
sFirstAddress = R.Address
i = 1
Do
Set R = .FindNext(R)
If R.Address < sFirstAddress Then
lLastCol = R(columnindex:=R.MergeArea.Columns.Count).Column
i = i + 1
End If
Loop Until R.Address = sFirstAddress
End With

Set R = Range(R, Cells(R.Row, lLastCol))

ReDim rTbl(1 To i, 0 To 2) 'dim 1 is table, 2 is TS text, 3 is List
ReDim sTblHeader(1 To i, 0 To 1) 'dimension 1 is text, 2 is address
For Each c In R
If Len(c.Text) 0 Then
j = j + 1
sTblHeader(j, 0) = c.Text
sTblHeader(j, 1) = c.Address
End If
Next c

For i = 1 To UBound(sTblHeader) 'iterate for each table
'get first row of table
With Cells
Set c = .Find(what:="Horse", after:=Range(sTblHeader(i, 1)), LookIn:=xlValues, _
lookat:=xlPart, searchdirection:=xlNext, searchorder:=xlByColumns, _
MatchCase:=True)
lFirstRow = c.Row
lLastCol = c.End(xlToRight).Column
Set c = .Find(what:="Horse", after:=Cells(Rows.Count, c.Column), searchdirection:=xlPrevious)
lLastRow = c.Row

'If all of the Prices are formed by functions/formulas, then change xlCellTypeConstants to xlCellTypeFormulas
' in the line below. Leave everything else the same

Set rTbl(i, 0) = Range(Cells(lFirstRow, c.Column + 1), Cells(lLastRow, lLastCol)).SpecialCells(xlCellTypeConstants, xlNumbers)

Set c = .Find(what:=Trim(Left(sTblHeader(i, 0), InStr(sTblHeader(i, 0), "-") - 1)), after:=c, _
LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlNext)
Set rTbl(i, 1) = c.Offset(rowoffset:=1) 'Trailer Text
Set rTbl(i, 2) = c.Offset(rowoffset:=1, columnoffset:=1) 'List Price

End With
Next i

For i = 1 To UBound(rTbl)
If Not Intersect(Target, rTbl(i, 0)) Is Nothing Then
rTbl(i, 1) = Replace(Cells(Target.End(xlUp).Row - 1, Target.End(xlToLeft).Column).Text, "/", " x ", 1, 1) & _
" / " & Target.End(xlToLeft).Text & " / " & _
Target.End(xlUp).Text & " Short Wall"
rTbl(i, 1).ShrinkToFit = True
rTbl(i, 2) = Target.Value
rTbl(i, 2).NumberFormat = "$#,##0"

'clear other entries
For j = 1 To UBound(rTbl)
If j < i Then
rTbl(j, 1).MergeArea.ClearContents
rTbl(j, 2).ClearContents
End If
Next j

End If
Next i

ExitPoint: ActiveSheet.Protect
Application.EnableEvents = True
If Err.Number < 0 Then MsgBox ("Error Occurred: Number: " & Err.Number & vbTab & Err.Description)
End Sub
==================================================