'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.

 

[ptkk1962]

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

there is some error in this code as it is missing in sorting some values

 

[My Aswer Is This]

Wow:
A lot of code here:
This is beyond my knowledgebase.
I will continue to monitor this thread to see what I can learn.

 

[ptkk1962]

Wow:
A lot of code here:
This is beyond my knowledgebase.
I will continue to monitor this thread to see what I can learn.

but there must be some way to apply this same code to other sheet

 

[ptkk1962]

Wow:
A lot of code here:
This is beyond my knowledgebase.
I will continue to monitor this thread to see what I can learn.

but i think it doesnot depend on how big the code is, method of applying this code to othersheet should remain same?

 

[ptkk1962]

but there must be some way to apply this same code to other sheet

please discuss with someone who can help

 

[My Aswer Is This]

but i think it doesnot depend on how big the code is, method of applying this code to othersheet should remain same?

Well you have the script with code like this:
Set rng1 = Sheet5.Range("B6:H" & intRng1)

I guess you could change
Set rng1 = Sheet5.Range("B6:H" & intRng1)

To Set rng1 = Sheet6.Range("B6:H" & intRng1)
and on and on change 5 to whatever you want

 

[My Aswer Is This]

I suspect you did not write this code, or you would surely know how to modify it

This is way too much code for me to read to even understand what the code is supposed to do.

 

[ptkk1962]

dear friends,
please suggest some solution,
please refer the code posted by me,is it possible to convert this code to power query.
regards

 

[ptkk1962]

if i raised a query and it is still not resolved,am i supposed to post it again?

 

[Fluff]

Please do not start a new thread, you need to continue in this one.