'copy vba code from one sheet and apply to another sheet'

[ptkk1962]

dear members and friends
'copy vba code from one sheet and apply to another sheet'
i searched the posts for this topic but it seems i could not find the solution or may be i missed a relevant post,
can some body teach how to do this.

 

[My Aswer Is This]

dear members and friends
'copy vba code from one sheet and apply to another sheet'
i searched the posts for this topic but it seems i could not find the solution or may be i missed a relevant post,
can some body teach how to do this.

You cannot copy the vba code from one sheet to another sheet
But you really do not need to do that.
The code can be written to perform the task on whatever sheet you want.

Show me the code you are wanting to copy

 

[My Aswer Is This]

Here is an example of code that will perform the same task on all sheets in your workbook.
This bit of code can be run from any worksheet button.
The script enters "Alpha" into all the sheets in your workbook Range("A1")

Sub My_Code()
'Modified 11/12/2022  1:02:00 AM  EST
Application.ScreenUpdating = False
Dim i As Long

For i = 1 To Sheets.Count
    Sheets(i).Range("A1").Value = "Alpha"
Next
Application.ScreenUpdating = True
End Sub

 

[ptkk1962]

Here is an example of code that will perform the same task on all sheets in your workbook.
This bit of code can be run from any worksheet button.
The script enters "Alpha" into all the sheets in your workbook Range("A1")

Sub My_Code()
'Modified 11/12/2022  1:02:00 AM  EST
Application.ScreenUpdating = False
Dim i As Long

For i = 1 To Sheets.Count
    Sheets(i).Range("A1").Value = "Alpha"
Next
Application.ScreenUpdating = True
End Sub

thanks a lot for your time to reply.god bless.
to be frank i donot know much about excel even.
can you guide me where should i write this code so that it works on all sheets on that workbook where one of the sheet is already having the code
which i wish to run on the other sheet.

 

[ptkk1962]

You cannot copy the vba code from one sheet to another sheet
But you really do not need to do that.
The code can be written to perform the task on whatever sheet you want.

Show me the code you are wanting to copy

can i send you the worksheet,but how to send?
for uploading the minisheet,it is asking me download some programme.

 

[My Aswer Is This]

thanks a lot for your time to reply.god bless.
to be frank i donot know much about excel even.
can you guide me where should i write this code so that it works on all sheets on that workbook where one of the sheet is already having the code
which i wish to run on the other sheet.

Take the code I wrote and put it in a button on any sheet

 

[My Aswer Is This]

I really do not need to see your workbook.
Just tell me in words what your wanting the script to do.

Be specific like
Put the value "Alpha" in Range("A1") on all sheets or if not, all sheets give me each sheet name

 

[ptkk1962]

I really do not need to see your workbook.
Just tell me in words what your wanting the script to do.

Be specific like
Put the value "Alpha" in Range("A1") on all sheets or if not, all sheets give me each sheet name

please check image
vba code is applied to 'Working file' when i enter a value in cell 'enter value to check' it works.
i wish to apply same code to other sheet 'me cur nxt mo' and 'enter value to check' button should be there on this sheet also

 

[My Aswer Is This]

I see no code. This image does not help me.
You need to explain in words what you want the script to do.
And post any code you have here for me to look at.

 

[ptkk1962]

I see no code. This image does not help me.
You need to explain in words what you want the script to do.
And post any code you have here for me to look at.

i think this the code

Public rng1 As Range, intRng1 As Integer
Public rng2 As Range, intRng2 As Integer
Public rng3 As Range, intRng3 As Integer
Public rng4 As Range, intRng4 As Integer
Public rng5 As Range, intRng5 As Integer
Public rng6 As Range, intRng6 As Integer
Public rng101 As Range
Public blnFound As Boolean
Public rngCol As Range
Public rngcell As Range

Public Const col_1 As Integer = 1
Public Const col_2 As Integer = 8
Public Const col_3 As Integer = 14
Public Const col_4 As Integer = 22
Public lngMain As Long

' Need to User lngMain ***************************************************************************************

'THIS CODE IS FOR TESTING
Sub Price_Change_Alert()
    Dim lngSearch As Long
   
    intRng1 = Sheet5.Range("B" & Rows.Count).End(xlUp).Row
    intRng2 = Sheet5.Range("J" & Rows.Count).End(xlUp).Row
    intRng3 = Sheet5.Range("R" & Rows.Count).End(xlUp).Row
    intRng4 = Sheet5.Range("Z" & Rows.Count).End(xlUp).Row
    intRng5 = Sheet5.Range("AH" & Rows.Count).End(xlUp).Row
    intRng6 = Sheet5.Range("AP" & Rows.Count).End(xlUp).Row
   
    DefaultFormatting intRng1, 1
    DefaultFormatting intRng2, 2
    DefaultFormatting intRng3, 3
    DefaultFormatting intRng4, 4
    DefaultFormatting intRng5, 5
    DefaultFormatting intRng6, 6
   
    lngSearch = Sheet5.Range("AX2")
   
    Set rng1 = Sheet5.Range("B6:H" & intRng1)
        rng1.Interior.Color = xlNone

    'calling function to find and format upper and lower values
    checkRangeValues rng1, 1, lngSearch
   
    Set rng2 = Sheet5.Range("J6:P" & intRng2)
        rng2.Interior.Color = xlNone

    'calling function to find and format upper and lower values
    checkRangeValues rng2, 2, lngSearch
   
    Set rng3 = Sheet5.Range("R6:X" & intRng3)
        rng3.Interior.Color = xlNone

    'calling function to find and format upper and lower values
    checkRangeValues rng3, 3, lngSearch
   
    Set rng4 = Sheet5.Range("Z6:AF" & intRng4)
        rng4.Interior.Color = xlNone

    'calling function to find and format upper and lower values
    checkRangeValues rng4, 4, lngSearch
   
    Set rng5 = Sheet5.Range("AH6:AN" & intRng5)
        rng5.Interior.Color = xlNone

    'calling function to find and format upper and lower values
    checkRangeValues rng4, 5, lngSearch
   
    Set rng6 = Sheet5.Range("AP6:AV" & intRng6)
        rng6.Interior.Color = xlNone

    'calling function to find and format upper and lower values
    checkRangeValues rng4, 6, lngSearch
   
    If blnFound = True Then
        MsgBox " Some Values met Conditions !", vbInformation, "Criteria Matched"
    Else
        MsgBox " Values Does not met Conditions !", vbExclamation, "Criteria Matched"
    End If

End Sub

Function DefaultFormatting(intLrow As Integer, intSec As Integer)
    Dim intFrow As Integer
    Dim x As Integer
   
    Select Case intSec
        Case 1
            If Sheet5.Cells(intLrow, 1).End(xlUp).Row <= 6 Then
                intFrow = 6
            Else
                intFrow = Sheet5.Cells(intLrow, 1).End(xlUp).Row
            End If
           
            Sheet5.Range("B" & intFrow & ":" & "H" & intLrow).Borders.Color = vbBlack
            Sheet5.Range("B" & intFrow & ":" & "H" & intLrow).Interior.Color = xlNone

        Case 2
           
            If Sheet5.Cells(intLrow, 9).End(xlUp).Row <= 6 Then
                intFrow = 6
            Else
                intFrow = Sheet5.Cells(intLrow, 8).End(xlUp).Row
            End If
           
            Sheet5.Range("J" & intFrow & ":" & "P" & intLrow).Borders.Color = vbBlack
            Sheet5.Range("J" & intFrow & ":" & "P" & intLrow).Interior.Color = xlNone

        Case 3
           
            If Sheet5.Cells(intLrow, 17).End(xlUp).Row <= 6 Then
                intFrow = 6
            Else
                intFrow = Sheet5.Cells(intLrow, 14).End(xlUp).Row
            End If
           
            Sheet5.Range("R" & intFrow & ":" & "X" & intLrow).Borders.Color = vbBlack
            Sheet5.Range("R" & intFrow & ":" & "X" & intLrow).Interior.Color = xlNone

        Case 4
       
            If Sheet5.Cells(intLrow, 25).End(xlUp).Row <= 6 Then
                intFrow = 6
            Else
                intFrow = Sheet5.Cells(intLrow, 22).End(xlUp).Row
            End If
       
            Sheet5.Range("Z" & intFrow & ":" & "AF" & intLrow).Borders.Color = vbBlack
            Sheet5.Range("Z" & intFrow & ":" & "AF" & intLrow).Interior.Color = xlNone
           
        Case 5
       
            If Sheet5.Cells(intLrow, 33).End(xlUp).Row <= 6 Then
                intFrow = 6
            Else
                intFrow = Sheet5.Cells(intLrow, 22).End(xlUp).Row
            End If
       
            Sheet5.Range("AH" & intFrow & ":" & "AN" & intLrow).Borders.Color = vbBlack
            Sheet5.Range("AH" & intFrow & ":" & "AN" & intLrow).Interior.Color = xlNone
           
        Case 6
       
            If Sheet5.Cells(intLrow, 41).End(xlUp).Row <= 6 Then
                intFrow = 6
            Else
                intFrow = Sheet5.Cells(intLrow, 22).End(xlUp).Row
            End If
       
            Sheet5.Range("AP" & intFrow & ":" & "AV" & intLrow).Borders.Color = vbBlack
            Sheet5.Range("AP" & intFrow & ":" & "AV" & intLrow).Interior.Color = xlNone

    End Select

End Function

Public Function checkRangeValues(dtRng As Range, strSection As Integer, intValtoFind As Long)
Dim x As Integer
Dim lngVal As Long
Dim intCol As Integer

' Call rounding nearest number function
lngVal = Round_Nearest(intValtoFind, strSection)

Select Case strSection
    Case 1
        intCol = 1
    Case 2
        intCol = 9
    Case 3
        intCol = 17
    Case 4
        intCol = 25
    Case 5
        intCol = 33
    Case 6
        intCol = 41
End Select
    Debug.Print dtRng.Address
    For Each rngCol In dtRng.Columns
        For Each rngcell In rngCol.Cells
            If Sheet5.Cells(rngcell.Row, intCol).Value = lngVal Then
                If rngcell >= 0.01 And rngcell <= 0.07 Then
                    ' Calling upper 5 values formating function
                    formatting_Cell_Upper rngcell
                    blnFound = True
                    ' Calling lower 5 values formating function
                    formatting_Cell_Lower rngcell
                    blnFound = True
                End If
            End If
        Next rngcell
    Next rngCol
End Function

Public Function Round_Nearest(lngNum As Long, strSection As Integer) As Long
    Dim intTens As Double
    Dim intHund As Double
   
    Dim rUp As Boolean
    Dim rDown As Boolean
   
    Select Case strSection
   
        Case 1, 2, 3, 4
       
            intTens = lngNum / 100
            intTens = Int(Round((intTens - Int(intTens)) * 100))

            If intTens <= 25 Then
                lngMain = (lngNum - intTens)
            ElseIf intTens > 25 And intTens <= 75 Then
                lngMain = (lngNum - intTens) + 50
            ElseIf intTens > 75 Then
                lngMain = (lngNum - intTens) + 100
            End If
           
        Case 5, 6
           
            intTens = lngNum / 1000
            intTens = Int(Round((intTens - Int(intTens)) * 1000))
            intTens = intTens / 100
            intTens = Int(Round((intTens - Int(intTens)) * 100))

            If intTens < 50 Then
                lngMain = lngNum - intTens
            Else
                lngMain = lngNum - intTens + 100
            End If
           
    End Select
   
    Round_Nearest = lngMain
End Function

Public Function formatting_Cell_Upper(rngMainCell As Range)
    rngMainCell.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
    rngMainCell.Borders.Color = RGB(255, 0, 0)
    rngMainCell.Interior.Color = vbYellow
    rngMainCell.Font.Bold = True
   
    For x = 7 To 1 Step -1
        If rngMainCell.Offset(x * -1, 0) >= 0.01 And rngMainCell.Offset(x * -1, 0) <= 0.13 Then
            If rngMainCell.Offset(x * -1, 0) <> "" Then
                rngMainCell.Offset(x * -1, 0).Interior.Color = RGB(255, 199, 206)
                rngMainCell.Offset(x * -1, 0).Borders.Color = RGB(0, 112, 192)
            End If
        End If
    Next x
End Function

Public Function formatting_Cell_Lower(rngMainCell As Range)
    rngMainCell.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
    rngMainCell.Borders.Color = RGB(255, 0, 0)
    rngMainCell.Interior.Color = vbYellow
    rngMainCell.Font.Bold = True
   
    For x = 1 To 7
        If rngMainCell.Offset(x, 0) >= 0.01 And rngMainCell.Offset(x, 0) <= 0.13 Then
            If rngMainCell.Offset(x, 0) <> "" Then
                rngMainCell.Offset(x, 0).Interior.Color = RGB(255, 199, 206)
                rngMainCell.Offset(x, 0).Borders.Color = RGB(0, 112, 192)
            End If
        End If
    Next x
End Function