R
Ron Rosenfeld
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.
You are using an out of date browser. It may not display this or other websites correctly.
You should upgrade or use an alternative browser.
You should upgrade or use an alternative browser.
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.
R
Ron Rosenfeld
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
========================================
S
smoborny
WOW! Works Great! You did a great job at listening for what I wanted an
getting it back to me in reasonable time. I am now wanting to be able t
protect the worksheet and still have the functions continue to work.
have protected the sheet and unlocked the protection for all cells wit
a price in it, and I still get an error. What must I change in the cod
to allow it to still function on a protected sheet
+-------------------------------------------------------------------
+-------------------------------------------------------------------
getting it back to me in reasonable time. I am now wanting to be able t
protect the worksheet and still have the functions continue to work.
have protected the sheet and unlocked the protection for all cells wit
a price in it, and I still get an error. What must I change in the cod
to allow it to still function on a protected sheet
+-------------------------------------------------------------------
+-------------------------------------------------------------------
R
Ron Rosenfeld
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?
R
Ron Rosenfeld
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
==================================================
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.