Happy day
Below is the data of my work and codes which I wrote with the help of google search. Data size will be variable.
I used numeric number "1" at the end of the workable range at the column c to identify the last row. I will enter values at the 8th row.
I used the match function and tricked by changing the intersect value to "0" and non-intersect value to "a" to make my code runnable.
Codes follows like this
Step 1:
Format in each row of column C to be copied to respective rows of given specified range.
Step 2 :
Check the each cell value in the given range is matching with any of the value in respective range of same row values at the right
Step 3:
If intersect(if cell value match with the value in the respective range of rows),respective cell to be formatted with respective column format and color from the top.
for example:
in row 10th --Values from the right most table say 1 , 8 is intersecting at G10,I10,M10,P10,S10,W10.The format from respective column at the 8th row will be copied to the respective intersecting cell.
My codes are running fine with very small range of 15 rows and 15 columns but taking too much when the specified range increased to 100 rows and 100 columns. For even more rows and columns, its taking very very too much time. So I need help to modify my codes to run faster or alternative codes are welcomed. I hope that i made clear of my requirement. Help would be appreciated.
Codes are below
Sub Latitude()
Dim FirstAddress As String
Dim Rng As Range
Dim i As Long
Dim ColumnNumber As Long
Dim ColumnLetter, ColumnLetter2 As String
Call longitude
'Get Last column from right and last row from bottom
Lastcolumn = ActiveSheet.Range("XFD8").End(xlToLeft).Column
ColumnLetter = Split(Cells(8, Lastcolumn).Address, "$")(1)
lastrow = ActiveSheet.Range("C1000000").End(xlUp).Row - 1
'Find the value using match
Range("E10:" & ColumnLetter & lastrow).ClearContents
Range("E10:" & ColumnLetter & lastrow).NumberFormat = ";;;" ' INVISIBLE
Range("E10:" & ColumnLetter & lastrow).FormulaR1C1 = "=IFERROR(MATCH(R8C," & "RC" & Lastcolumn + 3 & ":RC" & Lastcolumn + 19 & ",0)*0,""a"")"
'Copy and paste the formula values
Range("E10:" & ColumnLetter & lastrow).Select
Range("E10:" & ColumnLetter & lastrow).Copy
Range("E10:" & ColumnLetter & lastrow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Checking the values by looping and copy and pasting the formats from the top.
For i = 5 To Lastcolumn
ColumnLetter2 = Split(Cells(8, i).Address, "$")(1)
Range(ColumnLetter2 & 6).Select
Selection.Copy
Range(ColumnLetter2 & 10 & ":" & ColumnLetter2 & lastrow).Select
'On error move to next cell
On Error GoTo nextnext:
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeConstants, 1).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
nextnext:
Next i
Lastcolumn = ActiveSheet.Range("XFD8").End(xlToLeft).Column
Range("E10:" & ColumnLetter & lastrow).NumberFormat = ";;;" ' INVISIBLE
Application.ScreenUpdating = True
End Sub
Sub longitude()
Dim lastrow As Long
Dim ColumnLetter As String
Dim Lastcolumn As Long
Application.ScreenUpdating = False
'Find the last row using value
lastrow = ActiveSheet.Range("C1000000").End(xlUp).Row
Lastcolumn = ActiveSheet.Range("XFD8").End(xlToLeft).Column
ColumnLetter = Split(Cells(8, Lastcolumn).Address, "$")(1)
Range("E10:" & ColumnLetter & lastrow).Clear
For i = 10 To lastrow - 1
ActiveSheet.Range("C" & i).Copy (ActiveSheet.Range("E" & i & ":" & ColumnLetter & i))
Next i
End Sub
thanks in advance
Below is the data of my work and codes which I wrote with the help of google search. Data size will be variable.
I used numeric number "1" at the end of the workable range at the column c to identify the last row. I will enter values at the 8th row.
I used the match function and tricked by changing the intersect value to "0" and non-intersect value to "a" to make my code runnable.
Codes follows like this
Step 1:
Format in each row of column C to be copied to respective rows of given specified range.
Step 2 :
Check the each cell value in the given range is matching with any of the value in respective range of same row values at the right
Step 3:
If intersect(if cell value match with the value in the respective range of rows),respective cell to be formatted with respective column format and color from the top.
for example:
in row 10th --Values from the right most table say 1 , 8 is intersecting at G10,I10,M10,P10,S10,W10.The format from respective column at the 8th row will be copied to the respective intersecting cell.
My codes are running fine with very small range of 15 rows and 15 columns but taking too much when the specified range increased to 100 rows and 100 columns. For even more rows and columns, its taking very very too much time. So I need help to modify my codes to run faster or alternative codes are welcomed. I hope that i made clear of my requirement. Help would be appreciated.
Codes are below
Sub Latitude()
Dim FirstAddress As String
Dim Rng As Range
Dim i As Long
Dim ColumnNumber As Long
Dim ColumnLetter, ColumnLetter2 As String
Call longitude
'Get Last column from right and last row from bottom
Lastcolumn = ActiveSheet.Range("XFD8").End(xlToLeft).Column
ColumnLetter = Split(Cells(8, Lastcolumn).Address, "$")(1)
lastrow = ActiveSheet.Range("C1000000").End(xlUp).Row - 1
'Find the value using match
Range("E10:" & ColumnLetter & lastrow).ClearContents
Range("E10:" & ColumnLetter & lastrow).NumberFormat = ";;;" ' INVISIBLE
Range("E10:" & ColumnLetter & lastrow).FormulaR1C1 = "=IFERROR(MATCH(R8C," & "RC" & Lastcolumn + 3 & ":RC" & Lastcolumn + 19 & ",0)*0,""a"")"
'Copy and paste the formula values
Range("E10:" & ColumnLetter & lastrow).Select
Range("E10:" & ColumnLetter & lastrow).Copy
Range("E10:" & ColumnLetter & lastrow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Checking the values by looping and copy and pasting the formats from the top.
For i = 5 To Lastcolumn
ColumnLetter2 = Split(Cells(8, i).Address, "$")(1)
Range(ColumnLetter2 & 6).Select
Selection.Copy
Range(ColumnLetter2 & 10 & ":" & ColumnLetter2 & lastrow).Select
'On error move to next cell
On Error GoTo nextnext:
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeConstants, 1).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
nextnext:
Next i
Lastcolumn = ActiveSheet.Range("XFD8").End(xlToLeft).Column
Range("E10:" & ColumnLetter & lastrow).NumberFormat = ";;;" ' INVISIBLE
Application.ScreenUpdating = True
End Sub
Sub longitude()
Dim lastrow As Long
Dim ColumnLetter As String
Dim Lastcolumn As Long
Application.ScreenUpdating = False
'Find the last row using value
lastrow = ActiveSheet.Range("C1000000").End(xlUp).Row
Lastcolumn = ActiveSheet.Range("XFD8").End(xlToLeft).Column
ColumnLetter = Split(Cells(8, Lastcolumn).Address, "$")(1)
Range("E10:" & ColumnLetter & lastrow).Clear
For i = 10 To lastrow - 1
ActiveSheet.Range("C" & i).Copy (ActiveSheet.Range("E" & i & ":" & ColumnLetter & i))
Next i
End Sub
| codes for formatting.xlsm | ||||||||||||||||||||||||||||||||||||||||||
|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
| C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z | AA | AB | AC | AD | AE | AF | AG | AH | AI | AJ | AK | AL | AM | AN | AO | AP | |||
| 6 | Colors | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | |||||||||||||||||||||||||
| 7 | ||||||||||||||||||||||||||||||||||||||||||
| 8 | No | 3 | 4 | 1 | 5 | 8 | 3 | 6 | 7 | 8 | 2 | 5 | 8 | 9 | 2 | 8 | 9 | 3 | 4 | 1 | 2 | |||||||||||||||||||||
| 9 | ||||||||||||||||||||||||||||||||||||||||||
| 10 | 1 | 8 | ||||||||||||||||||||||||||||||||||||||||
| 11 | 2 | 9 | ||||||||||||||||||||||||||||||||||||||||
| 12 | 3 | 8 | ||||||||||||||||||||||||||||||||||||||||
| 13 | 3 | 9 | ||||||||||||||||||||||||||||||||||||||||
| 14 | 4 | 8 | ||||||||||||||||||||||||||||||||||||||||
| 15 | 4 | 9 | ||||||||||||||||||||||||||||||||||||||||
| 16 | 2 | 3 | 5 | 8 | ||||||||||||||||||||||||||||||||||||||
| 17 | 6 | 6 | 9 | |||||||||||||||||||||||||||||||||||||||
| 18 | 1 | 2 | 3 | 8 | ||||||||||||||||||||||||||||||||||||||
| 19 | 9 | |||||||||||||||||||||||||||||||||||||||||
| 20 | 7 | 8 | ||||||||||||||||||||||||||||||||||||||||
| 21 | 6 | 9 | ||||||||||||||||||||||||||||||||||||||||
| 22 | 5 | 8 | ||||||||||||||||||||||||||||||||||||||||
| 23 | 4 | 9 | ||||||||||||||||||||||||||||||||||||||||
| 24 | 1 | 2 | 3 | 8 | ||||||||||||||||||||||||||||||||||||||
| 25 | 4 | 5 | 6 | 7 | 9 | |||||||||||||||||||||||||||||||||||||
| 26 | 1 | |||||||||||||||||||||||||||||||||||||||||
Drawing | ||||||||||||||||||||||||||||||||||||||||||
thanks in advance
