Controlling the decimal places on other Sheets

I have a very nice, clean piece of code that MartinLiss sent to me that works flawlessly.  It changes the decimal point format in the event a particular cell is referenced.  

Now however, I need to have it respond in the same way to other Worksheets so I need a few lines of code that identify the other Worksheet and the specific cells that need to be under this macro.


The Code resides in one Worksheet (Currency) now but is applied to the "Customer Input Worksheet" and may need to be moved into a module since I'm trying to reference other Sheets (Maybe not) (Customer Data - Cell E10).  

The exact line that now refers to the Customer Input Worksheet that needs to reference also the other Worksheet (Customer Data) is:

If sRange = "C18,c25,c36,c52,c59,c68,c75,c83,c94,c101" Then




Actual Code:

Option Explicit

Const SelectedCurrency As String = "D4"
Const CurrencyList As String = "B4:B12"
Const ChangeCellStart As String = "E4"

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rFind As Range, rStep As Range
    Dim sSheet As String, sRange As String
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Address = Me.Range(SelectedCurrency).Address Then
        Set rFind = Me.Range(CurrencyList).Find(What:=Target.Value, LookAt:=xlWhole)
        If Not rFind Is Nothing Then
            For Each rStep In Me.Range(Me.Range(ChangeCellStart), Me.Cells(Me.Rows.Count, Me.Range(ChangeCellStart).Column).End(xlUp))
                On Error Resume Next
                If InStr(1, rStep.Value, "!") = 0 Then
                    Me.Range(rStep.Value).NumberFormat = rFind.Offset(0, 1).NumberFormat
                Else
                    sSheet = Trim(Left(rStep.Value, InStr(1, rStep.Value, "!") - 1))
                    sRange = Trim(Right(rStep.Value, Len(rStep.Value) - InStr(1, rStep.Value, "!")))
                    If Left(sSheet, 1) = "'" Then sSheet = Right(sSheet, Len(sSheet) - 1)
                    If Right(sSheet, 1) = "'" Then sSheet = Left(sSheet, Len(sSheet) - 1)
                   
                    If sRange = "C18,c25,c36,c52,c59,c68,c75,c83,c94,c101" Then
                        strNF = rFind.Offset(0, 1).NumberFormat
                    Else
                        strNF = Replace(rFind.Offset(0, 1).NumberFormat, ".00", "")
                    End If
                   
                                       
                    ThisWorkbook.Worksheets(sSheet).Range(sRange).NumberFormat = rFind.Offset(0, 1).NumberFormat
                End If
                On Error GoTo 0
            Next rStep
        End If
    End If
End Sub

Thank you in Advance!

B.
Changing-the-decimal-format.xlsm
Bright01Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

[ fanpages ]IT Services ConsultantCommented:
Hi,

The (This)Workbook code module offers an event similar to the Worksheet_Change() event, but is a "catch all" routine that will be called whenever any worksheet within the workbook is changed:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

End Sub


I would suggest moving Marty's code from the local worksheet, [Currency], & slightly modifying it within the Workbook_SheetChange(...) event to cater for more than one worksheet, as I have indicated below.

I have also replaced the reference to "Me." to "Sh." (the parameter that refers to the individual worksheet object that has changed):

Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

  Dim rFind As Range
  Dim rStep As Range
  Dim sSheet As String
  Dim sRange As String
  Dim strNF As String

  Dim SelectedCurrency                                  As String
  Dim CurrencyList                                      As String
  Dim ChangeCellStart                                   As String
  
  Select Case (UCase$(Sh.Name))
  
      Case ("CURRENCY")
          SelectedCurrency = "D4"
          CurrencyList = "B4:B12"
          ChangeCellStart = "E4"
          
     Case ("CUSTOMER DATA")
          SelectedCurrency = "..."                      ' *** CHANGE THIS
          CurrencyList = "..."                          ' *** CHANGE THIS
          ChangeCellStart = "..."                       ' *** CHANGE THIS
          
     Case Else
         Exit Sub
         
  End Select

  If Target.Cells.Count > 1 Then
     Exit Sub
  End If
  
  If Target.Address = Sh.Range(SelectedCurrency).Address Then
     Set rFind = Sh.Range(CurrencyList).Find(What:=Target.Value, LookAt:=xlWhole)
     
     If Not rFind Is Nothing Then
        For Each rStep In Sh.Range(Sh.Range(ChangeCellStart), Sh.Cells(Sh.Rows.Count, Sh.Range(ChangeCellStart).Column).End(xlUp))
            
            On Error Resume Next
            
            If InStr(1, rStep.Value, "!") = 0 Then
               Sh.Range(rStep.Value).NumberFormat = rFind.Offset(0, 1).NumberFormat
            Else
               sSheet = Trim(Left(rStep.Value, InStr(1, rStep.Value, "!") - 1))
               sRange = Trim(Right(rStep.Value, Len(rStep.Value) - InStr(1, rStep.Value, "!")))
               
               If Left(sSheet, 1) = "'" Then
                  sSheet = Right(sSheet, Len(sSheet) - 1)
               End If
               
               If Right(sSheet, 1) = "'" Then
                  sSheet = Left(sSheet, Len(sSheet) - 1)
               End If
               
               If sRange = "C9" Then                    ' *** CHECK THIS!!!
                  strNF = rFind.Offset(0, 1).NumberFormat
               Else
                  strNF = Replace(rFind.Offset(0, 1).NumberFormat, ".00", "")
               End If
               
               ThisWorkbook.Worksheets(sSheet).Range(sRange).NumberFormat = strNF
            End If
            
            On Error GoTo 0
            
        Next rStep
     End If
  End If
  
End Sub

Open in new window



Please note the three statements I have suffixed with the in-line comment ' *** CHANGE THIS.

Also, the single statement I have suffixed with the comment ' *** CHECK THIS!!!.


BFN,

fp.
0
Bright01Author Commented:
fp,

Thanks for jumping in here.  I've been looking over this code and have a few questions.  What do I put in on the lines  *** CHANGE THIS?  

Let me be more specific about what this code does.  When I change the Currency on the Currency Sheet, it changes all of the identified cells in the Workbook I have.  The problem I had then was that I have numbers that span from $.07 to $5,600,000 and so I used Marty's code to identify where I have cells that need to be treated as currency (which you select at the beginning) and need two decimal places.

Hopefully that's what you realized with the code I provided.

So I have moved Marty's code to This Worksheet and am now comparing your and his code to see how I make yours work.  This is where I'm challenged.  

1.) So do I make "A Case" for each worksheet I want to have a cell changed on?
2.) Do I need to modify the ***CHECK THIS Statement?

A little detail would help out here.

Thank you,

B.
0
Bright01Author Commented:
I've been trying to work with this but am still confused.  How does the Macro know which cells to change on which Worksheet?  Is it in the;

CASE ID?

Case ("CUSTOMER DATA")
          SelectedCurrency = "..."                      ' *** CHANGE THIS
          CurrencyList = "..."                          ' *** CHANGE THIS
          ChangeCellStart = "..."                       ' *** CHANGE THIS
         
If so, do I need to identify each sheet where the cells are going to be affected as I did on the original code with my line;

If sRange = "C18,c25,c36,c52,c59,c68,c75,c83,c94,c101" Then

?

I'll keep trying.......

B.
0
Newly released Acronis True Image 2019

In announcing the release of the 15th Anniversary Edition of Acronis True Image 2019, the company revealed that its artificial intelligence-based anti-ransomware technology – stopped more than 200,000 ransomware attacks on 150,000 customers last year.

Martin LissOlder than dirtCommented:
The attached workbook contains this modified code. To add more sheets you just need to add a new cell value in sheet Currency, column E as I have done and add a new Case statement as in lines 23 and 24 for any other sheet.
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rFind As Range, rStep As Range
    Dim sSheet As String, sRange As String
    Dim strNF As String
    Dim strCell As String

    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Address = Me.Range(SelectedCurrency).Address Then
        Set rFind = Me.Range(CurrencyList).Find(What:=Target.Value, LookAt:=xlWhole)
        If Not rFind Is Nothing Then
            For Each rStep In Me.Range(Me.Range(ChangeCellStart), Me.Cells(Me.Rows.Count, Me.Range(ChangeCellStart).Column).End(xlUp))
                On Error Resume Next
                If InStr(1, rStep.Value, "!") = 0 Then
                    Me.Range(rStep.Value).NumberFormat = rFind.Offset(0, 1).NumberFormat
                Else
                    sSheet = Trim(Left(rStep.Value, InStr(1, rStep.Value, "!") - 1))
                    sRange = Trim(Right(rStep.Value, Len(rStep.Value) - InStr(1, rStep.Value, "!")))
                    If Left(sSheet, 1) = "'" Then sSheet = Right(sSheet, Len(sSheet) - 1)
                    If Right(sSheet, 1) = "'" Then sSheet = Left(sSheet, Len(sSheet) - 1)
                    Select Case sSheet
                        Case "Customer - Inputs"
                            strCell = "C9"
                        Case "Customer Data"
                            strCell = "E10"
                    End Select
                    If sRange = strCell Then
                        strNF = rFind.Offset(0, 1).NumberFormat
                    Else
                        strNF = Replace(rFind.Offset(0, 1).NumberFormat, ".00", "")
                    End If
                    ThisWorkbook.Worksheets(sSheet).Range(sRange).NumberFormat = strNF
                End If
                On Error GoTo 0
            Next rStep
        End If
    End If
End Sub

Open in new window

Q-28264436.xlsm
0
Bright01Author Commented:
Marty,

The code works great.  However, when I put it in my production WB, it doesn't respect the decimal part of the macro for some reason..... it gives me all two digit numbers.  I can live with that; however, in trying to trouble shoot it the only thing that I can find that is different with your code and my full WB is that I have multiple cell references;

EXAMPLE:   Instead of "C9", I would have "C9, C12, C15, C18, C30".  

So I'm wondering if it could be the difference between having a statement;

StrCell and having a StrRange........

Any final ideas here that I may trouble shoot?

Otherwise, your code works perfectly.

B.
0
Martin LissOlder than dirtCommented:
The cells specified in the Case statement shown below from the Currency sheet's Worksheet_Change event are the ones that get the number formatting with decimals. Any other cell(s) in the 'Change Field Table' get whole numbers.

                        Case "Customer - Inputs"
                            strCell = "C9"
                        Case "Customer Data"
                            strCell = "E10"

Open in new window


So since that table looks like this

Change Field Table
'Customer - Inputs!C9
'Customer - Inputs!C11
 Customer Data!E10

Customer - Inputs cell C9 get's the decimal formatting but C11 gets the whole number formatting. In the case of the Customer Data sheet E10 gets the decimal formatting and if you want some other cell to get the whole number formatting you need to add it to the table like so

Change Field Table
'Customer - Inputs!C9
'Customer - Inputs!C11
 Customer Data!E10
 Customer Data!E12

where E12 would be formatted as a whole number.
0
Bright01Author Commented:
So what if I wanted multiple cells to get the decimal format on the same WS?  Such as the case with C9 which is already configured, but add C11 and C16 in the Customer - Input WS?

                        Case "Customer - Inputs"
                            strCell = "C9"

would it be:       strCell = "C9, C11, C16"
                                         

B.
0
Martin LissOlder than dirtCommented:
No that wouldn't work. As written, IMO, the whole process is awkward. Give me a little while and let me see if I can come up with something that's easier to maintain.
0
Martin LissOlder than dirtCommented:
Here's an updated version that contains the code below. In the workbook you'll see that I added a second Field table to the Currency sheet. The the first Field table is where you enter the cells you want formatted with decimals and the second is where you enter the cells you want formatted as whole numbers. The new code is based on two new Named Ranges named 'FormatDecimal' and 'FormatWholeNumber' which automatically adjust to the number of entries in each of the two Field columns.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rFind As Range, rStep As Range
    Dim sSheet As String, sRange As String
    Dim strNF As String
    Dim strCell As String
    
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Address = Me.Range(SelectedCurrency).Address Then
        Set rFind = Me.Range(CurrencyList).Find(What:=Target.Value, LookAt:=xlWhole)
        If Not rFind Is Nothing Then
            ' Process decimal formatting
            For Each rStep In Me.Range(Me.Range(ChangeCellStart), Me.Cells(Me.Rows.Count, Me.Range(ChangeCellStart).Column).End(xlUp))
                On Error Resume Next
                If InStr(1, rStep.Value, "!") = 0 Then
                    Me.Range(rStep.Value).NumberFormat = rFind.Offset(0, 1).NumberFormat
                Else
                    sSheet = Trim(Left(rStep.Value, InStr(1, rStep.Value, "!") - 1))
                    sRange = Trim(Right(rStep.Value, Len(rStep.Value) - InStr(1, rStep.Value, "!")))
                    strNF = rFind.Offset(0, 1).NumberFormat
                    ThisWorkbook.Worksheets(sSheet).Range(sRange).NumberFormat = strNF
                End If
                On Error GoTo 0
            Next rStep
            
            ' Process whole number formatting
            For Each rStep In Me.Range(Me.Range(ChangeCellStart).Offset(0, 1), _
                              Me.Cells(Me.Rows.Count, Me.Range(ChangeCellStart).Offset(0, 1).Column).End(xlUp))
                On Error Resume Next
                If InStr(1, rStep.Value, "!") = 0 Then
                    Me.Range(rStep.Value).NumberFormat = rFind.Offset(0, 1).NumberFormat
                Else
                    sSheet = Trim(Left(rStep.Value, InStr(1, rStep.Value, "!") - 1))
                    sRange = Trim(Right(rStep.Value, Len(rStep.Value) - InStr(1, rStep.Value, "!")))
                    strNF = Replace(rFind.Offset(0, 1).NumberFormat, ".00", "")
                    ThisWorkbook.Worksheets(sSheet).Range(sRange).NumberFormat = strNF
                End If
                On Error GoTo 0
            Next rStep
        End If
    End If
End Sub

Open in new window

Q-28264436-2.xlsm
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Bright01Author Commented:
Marty,

Your code works flawlessly.  I however, have made a big mistake in my conversation with you and didn't realize it until I started putting your code into my WB.

Here's the problem, FanPages (FP) was kind enough to give me some additional code, from your original, that allowed for me to have the selection of currency on the "Customer - Input" WS.  In order to do so, he advised that I had to move the code in "Currency" to the Customer - Input" WS and make the modifications that FP suggested.  I did it and it worked well, but still had the problem with the decimal points  (it did not work by changing any cells to whole numbers.  When I got your new fix with the improvements, it had the selection still being made on the original Currency WS without FP's changes to accommodate the requirement for the new location of the selection of currency.

Now, I don't know how to fix it.  Do I take your code and simply try to refer the selection of Currency to the Customer - Input WS or do I take what FP delivered and try to add your additions?  I've tried that but it's broken completely down.  I tried to move your code over and add his additions and again..... no luck.  

I am so sorry for this confusion.  I have two choices;

1.) Simply author another question and build off what you have sent me; requesting that the Currency Selection gets moved to the "Customer - Input" tab, or continue to try to fix FP's code by integrating your new design.  Any advise would be much appreciated.

Here is FP's code changes to handle the move of that one cell, that I now have in the "Customer - Input" WS:

Option Explicit

Const SelectedCurrency As String = "F2"                                 ' *** fp. [26/09/2013]: Changed from "D4" to "F2"
Const CurrencyList As String = "B4:B12"
Const ChangeCellStart As String = "E4"

Private Sub Worksheet_Change(ByVal Target As Range)
   
  Dim objMe                                             As Worksheet    ' *** fp. [26/09/2013]: Added
  Dim rFind                                             As Range
  Dim rStep                                             As Range
  Dim sSheet                                            As String
  Dim sRange                                            As String
 
  Set objMe = Worksheets("Currency")                                    ' *** fp. [26/09/2013]: Added
 
  If Target.Cells.Count > 1& Then
     Exit Sub
  End If ' If Target.Cells.Count > 1& Then
 
  If Target.Address = objMe.Range(SelectedCurrency).Address Then
     Set rFind = objMe.Range(CurrencyList).Find(What:=Target.Value, LookAt:=xlWhole)
     
     If Not rFind Is Nothing Then
        For Each rStep In objMe.Range(objMe.Range(ChangeCellStart), objMe.Cells(objMe.Rows.Count, objMe.Range(ChangeCellStart).Column).End(xlUp))
       
            On Error Resume Next
           
            If InStr(1, rStep.Value, "!") = 0 Then
               objMe.Range(rStep.Value).NumberFormat = rFind.Offset(0, 1).NumberFormat
            Else
               sSheet = Trim(Left(rStep.Value, InStr(1, rStep.Value, "!") - 1))
               sRange = Trim(Right(rStep.Value, Len(rStep.Value) - InStr(1, rStep.Value, "!")))
               
               If Left(sSheet, 1) = "'" Then
                  sSheet = Right(sSheet, Len(sSheet) - 1)
               End If ' If Left(sSheet, 1) = "'" Then
               
               If Right(sSheet, 1) = "'" Then
                  sSheet = Left(sSheet, Len(sSheet) - 1)
               End If ' If Right(sSheet, 1) = "'" Then
               
               ThisWorkbook.Worksheets(sSheet).Range(sRange).NumberFormat = rFind.Offset(0, 1).NumberFormat
            End If ' If InStr(1, rStep.Value, "!") = 0 Then
           
            On Error GoTo 0
           
            Next rStep
        End If ' If Not rFind Is Nothing Then
    End If ' If Target.Address = objMe.Range(SelectedCurrency).Address Then

End Sub
0
Martin LissOlder than dirtCommented:
Post your workbook and I'll fix it.
0
Bright01Author Commented:
Marty,

I'm closing out this question.  You did a fabulous job on getting my question answered and I appreciate it.  I'll be authoring another question that may simplify my request by taking what you have already done and moving the request for currency to a specific cell on the Customer - Input WS.  You did everything I asked and then some and it is only fair that I author another question to get the result I need for my production WB.  

Thank you again, and I hope you will pick up the next Question.

All the best,

B.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Applications

From novice to tech pro — start learning today.