Help Needed to make this macro faster

[Sathya89]

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

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

 

[Akuini]

@Sathya89
1. Why do you use loop to format the row in this part:
For i = 10 To lastrow - 1
ActiveSheet.Range("C" & i).Copy (ActiveSheet.Range("E" & i & ":" & ColumnLetter & i))
Next i
it will be faster if you do it in one go.

2. In your example you are using 2 colors for columns, if your data says it has 100 columns, how many colors do you use?
It would be faster if you could identify the columns that have the same color & then format them all at once.

3. 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.
How long did it take for 100 rows and 100 columns?

 

[Sathya89]

really thanks for your reply.

For point 1:--I will copy and do paste as per your suggestion.
For point 2- I may use maximum of 15 colors
For point 3 - more than 45 seconds for more than 100 rows and 100 columns.

 

[Sathya89]

1. Why do you use loop to format the row in this part:
For i = 10 To lastrow - 1
ActiveSheet.Range("C" & i).Copy (ActiveSheet.Range("E" & i & ":" & ColumnLetter & i))
Next i
it will be faster if you do it in one go.

For point 1 - i will use more than 1 color in rows too. And so I used this code because when creating more than 100 rows.i have to select particular range of rows for different colors each time.

For point 2 : is there VBA code to identify the columns with same color to execute the intersection cells with column colors at one go.

 

[Eric W]

There are still a few places for improvement, but see if this works for you:

Sub SetHighlight()
Dim lr As Long, lc As Long, r As Long, c As Long, r1 As Long, c1 As Long
Dim rng1 As Variant, rng2 As Range, cols(1 To 1000), vals(1 To 1000)

    lr = Cells(Rows.Count, "C").End(xlUp).Row - 1
    lc = Cells(8, Columns.Count).End(xlToLeft).Column
    
    For c = 5 To lc
        cols(c) = Cells(6, c).Interior.Color
        vals(c) = Cells(8, c).Value
    Next c
    
    Range(Range("E10"), Cells(lr, lc)).Interior.Color = xlNone
    rng1 = Range(Cells(10, lc + 3), Cells(lr, lc + 19)).Value
    
    On Error Resume Next
    For c = 5 To lc
        If cols(c) > 0 Then
            Set rng2 = Nothing
            For c1 = c To lc
                If cols(c1) = cols(c) Then
                    For r1 = 10 To lr
                        Err.Clear
                        x = WorksheetFunction.Match(vals(c1), WorksheetFunction.Index(rng1, r1 - 9, 0), 0)
                        If Err.Number = 0 Then
                            If rng2 Is Nothing Then
                                Set rng2 = Cells(r1, c1)
                            Else
                                Set rng2 = Union(rng2, Cells(r1, c1))
                            End If
                        End If
                    Next r1
                End If
            Next c1
            If Not rng2 Is Nothing Then rng2.Interior.Color = cols(c)
        End If
        For c1 = c To lc
            If cols(c) = cols(c1) Then cols(c1) = -2
        Next c1
    Next c
                              
End Sub

 

[Sathya89]

There are still a few places for improvement, but see if this works for you:

Sub SetHighlight()
Dim lr As Long, lc As Long, r As Long, c As Long, r1 As Long, c1 As Long
Dim rng1 As Variant, rng2 As Range, cols(1 To 1000), vals(1 To 1000)

    lr = Cells(Rows.Count, "C").End(xlUp).Row - 1
    lc = Cells(8, Columns.Count).End(xlToLeft).Column
   
    For c = 5 To lc
        cols(c) = Cells(6, c).Interior.Color
        vals(c) = Cells(8, c).Value
    Next c
   
    Range(Range("E10"), Cells(lr, lc)).Interior.Color = xlNone
    rng1 = Range(Cells(10, lc + 3), Cells(lr, lc + 19)).Value
   
    On Error Resume Next
    For c = 5 To lc
        If cols(c) > 0 Then
            Set rng2 = Nothing
            For c1 = c To lc
                If cols(c1) = cols(c) Then
                    For r1 = 10 To lr
                        Err.Clear
                        x = WorksheetFunction.Match(vals(c1), WorksheetFunction.Index(rng1, r1 - 9, 0), 0)
                        If Err.Number = 0 Then
                            If rng2 Is Nothing Then
                                Set rng2 = Cells(r1, c1)
                            Else
                                Set rng2 = Union(rng2, Cells(r1, c1))
                            End If
                        End If
                    Next r1
                End If
            Next c1
            If Not rng2 Is Nothing Then rng2.Interior.Color = cols(c)
        End If
        For c1 = c To lc
            If cols(c) = cols(c1) Then cols(c1) = -2
        Next c1
    Next c
                             
End Sub

Thanks for your reply. Copied your code and executed but the code you have given didn't work well. It is not only getting too much time( more than 4 mins) for copying only the colors (not the borders) from the columns but also not copying the colors from the rows. I hope that I clearly explained my requirement.

 

[Eric W]

OK, it should copy the row colors now. I also found a bug which would have seriously affected the run time on large ranges. I'm still working on the borders. Try this out:

Sub SetHighlight()
Dim lr As Long, lc As Long, r As Long, c As Long, r1 As Long, c1 As Long
Dim rng1 As Variant, rng2 As Range, cols(1 To 1000), rowz(1 To 1000), vals(1 To 1000)

    lr = Cells(Rows.Count, "C").End(xlUp).Row - 1
    lc = Cells(8, Columns.Count).End(xlToLeft).Column
    
    Range("ZZ999").Copy Range(Range("E10"), Cells(lr, lc))
    
    For c = 5 To lc
        cols(c) = Cells(6, c).Interior.Color
        vals(c) = Cells(8, c).Value
    Next c
    
    For r = 10 To lr
        rowz(r) = Cells(r, "C").Interior.Color
    Next r
    For r = 10 To lr
        If rowz(r) > 0 Then
            Set rng2 = Nothing
            For r1 = r To lr
                If rowz(r) = rowz(r1) Then
                    If rng2 Is Nothing Then
                        Set rng2 = Range(Cells(r1, "E"), Cells(r1, lc))
                    Else
                        Set rng2 = Union(rng2, Range(Cells(r1, "E"), Cells(r1, lc)))
                    End If
                End If
            Next r1
            If Not rng2 Is Nothing Then
                rng2.Interior.Color = rowz(r)
                rng2.Borders(xlEdgeTop).LineStyle = xlContinuous
                rng2.Borders(xlEdgeBottom).LineStyle = xlContinuous
                rng2.Borders(xlInsideHorizontal).LineStyle = xlContinuous
            End If
            For r1 = lr To r Step -1
                If rowz(r) = rowz(r1) Then rowz(r1) = -2
            Next r1
        End If
    Next r
    
    rng1 = Range(Cells(10, lc + 3), Cells(lr, lc + 19)).Value
    
    On Error Resume Next
    For c = 5 To lc
        If cols(c) > 0 Then
            Set rng2 = Nothing
            For c1 = c To lc
                If cols(c1) = cols(c) Then
                    For r1 = 10 To lr
                        Err.Clear
                        x = WorksheetFunction.Match(vals(c1), WorksheetFunction.Index(rng1, r1 - 9, 0), 0)
                        If Err.Number = 0 Then
                            If rng2 Is Nothing Then
                                Set rng2 = Cells(r1, c1)
                            Else
                                Set rng2 = Union(rng2, Cells(r1, c1))
                            End If
                        End If
                    Next r1
                End If
            Next c1
            If Not rng2 Is Nothing Then
                rng2.Interior.Color = cols(c)
                rng2.Borders(xlEdgeLeft) = xlContinuous
                rng2.Borders(xlEdgeRight) = xlContinuous
                rng2.Borders(xlInsideVertical) = xlcontinous
            End If
        End If
        For c1 = lc To c Step -1
            If cols(c) = cols(c1) Then cols(c1) = -2
        Next c1
    Next c
                              
End Sub

There's still one thing I can do that might speed it up, but check this out first. The main benefit is that it only reads/writes to the worksheet a minimum number of times. Which is why the borders are not working so hot - disjoint ranges don't seem to handle borders well.

 

[Akuini]

@Sathya89
Try this:
1. It uses temporary helper columns.
Set d = c.Offset(, rc * 2 + 100) 'temporary helper column, change to suit

2. The code copy-paste the format all at once, so it should be faster:

'copy format C to E10:X25 format
Range(Cells(10, "C"), Cells(n, "C")).Copy
c.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

And

'paste format from helper column to E10:X25 with SkipBlanks:=True
c.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=True, Transpose:=False

Sub a1173102a()
'https://www.mrexcel.com/board/threads/help-needed-to-make-this-macro-faster.1173102/
Dim c As Range, d As Range
Dim i As Long, j As Long, n As Long
Dim k As Long, rc As Long
Dim va, vb, vc, t

t = Timer
Application.ScreenUpdating = False
n = Range("C" & Rows.Count).End(xlUp).Row - 1
rc = Cells(8, Columns.Count).End(xlToLeft).Column

Set c = Range(Cells(10, "E"), Cells(n, rc)) 'E10:X25
Set d = c.Offset(, rc * 2 + 100) 'temporary helper column, change to suit

c.Clear
'copy format C to E10:X25 format
Range(Cells(10, "C"), Cells(n, "C")).Copy
c.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

'copy format to temporary helper column
Range(Cells(6, "E"), Cells(6, rc)).Copy
d.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

'populating array
va = Range(Cells(8, "E"), Cells(8, rc)) 'row 8: range E8:X8
vb = c.Offset(, c.Columns.Count + 2)    'range AA10:AP25, assuming 2 columns separate the 2 areas (i.e E10:X25 & AA10:AP25)
vc = d                                  'temporary helper column, empty

For i = 1 To UBound(vb, 1)

    For j = 1 To UBound(vb, 2)
    
        If vb(i, j) <> "" Then
        
            For k = 1 To UBound(va, 2)
                
                If va(1, k) = vb(i, j) Then vc(i, k) = 0
            
            Next
        
        End If
    
    Next

Next

'populate result to temporary helper column
d = vc
d.Copy
'paste format from helper column to E10:X25 with SkipBlanks:=True
c.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=True, Transpose:=False

Application.CutCopyMode = False
d.Clear 'clear temporary helper column

Application.ScreenUpdating = True

Debug.Print "It's done in: " & Timer - t & " seconds"

End Sub

 

[Sathya89]

For i = 1 To UBound(vb, 1) For j = 1 To UBound(vb, 2) If vb(i, j) <> "" Then For k = 1 To UBound(va, 2) If va(1, k) = vb(i, j) Then vc(i, k) = 0 Next End If Next Next 'populate result to temporary helper column d = vc d.Copy

Awesome. I was shocked and mind blowing. Really worked in a matter of a second(0.34375 seconds) for 400 rows x 200 columns. it is very very faster. I was really felt stress less and smiled after running the codes. I understood the remaining One small help.im a dummy and a beginner to this VBA code. May you give in tabular format of this array so that I can understand ,how this is working.

And I need reverse of this code i.e selecting and formatting the non-intersecting cells. I don't where to edit this code.

I found that even if add more values above 16 at the right most range. The codes work fine.

Once again thanks a lot.

 

[Sathya89]

T

OK, it should copy the row colors now. I also found a bug which would have seriously affected the run time on large ranges. I'm still working on the borders. Try this out:

Sub SetHighlight()
Dim lr As Long, lc As Long, r As Long, c As Long, r1 As Long, c1 As Long
Dim rng1 As Variant, rng2 As Range, cols(1 To 1000), rowz(1 To 1000), vals(1 To 1000)

    lr = Cells(Rows.Count, "C").End(xlUp).Row - 1
    lc = Cells(8, Columns.Count).End(xlToLeft).Column
  
    Range("ZZ999").Copy Range(Range("E10"), Cells(lr, lc))
  
    For c = 5 To lc
        cols(c) = Cells(6, c).Interior.Color
        vals(c) = Cells(8, c).Value
    Next c
  
    For r = 10 To lr
        rowz(r) = Cells(r, "C").Interior.Color
    Next r
    For r = 10 To lr
        If rowz(r) > 0 Then
            Set rng2 = Nothing
            For r1 = r To lr
                If rowz(r) = rowz(r1) Then
                    If rng2 Is Nothing Then
                        Set rng2 = Range(Cells(r1, "E"), Cells(r1, lc))
                    Else
                        Set rng2 = Union(rng2, Range(Cells(r1, "E"), Cells(r1, lc)))
                    End If
                End If
            Next r1
            If Not rng2 Is Nothing Then
                rng2.Interior.Color = rowz(r)
                rng2.Borders(xlEdgeTop).LineStyle = xlContinuous
                rng2.Borders(xlEdgeBottom).LineStyle = xlContinuous
                rng2.Borders(xlInsideHorizontal).LineStyle = xlContinuous
            End If
            For r1 = lr To r Step -1
                If rowz(r) = rowz(r1) Then rowz(r1) = -2
            Next r1
        End If
    Next r
  
    rng1 = Range(Cells(10, lc + 3), Cells(lr, lc + 19)).Value
  
    On Error Resume Next
    For c = 5 To lc
        If cols(c) > 0 Then
            Set rng2 = Nothing
            For c1 = c To lc
                If cols(c1) = cols(c) Then
                    For r1 = 10 To lr
                        Err.Clear
                        x = WorksheetFunction.Match(vals(c1), WorksheetFunction.Index(rng1, r1 - 9, 0), 0)
                        If Err.Number = 0 Then
                            If rng2 Is Nothing Then
                                Set rng2 = Cells(r1, c1)
                            Else
                                Set rng2 = Union(rng2, Cells(r1, c1))
                            End If
                        End If
                    Next r1
                End If
            Next c1
            If Not rng2 Is Nothing Then
                rng2.Interior.Color = cols(c)
                rng2.Borders(xlEdgeLeft) = xlContinuous
                rng2.Borders(xlEdgeRight) = xlContinuous
                rng2.Borders(xlInsideVertical) = xlcontinous
            End If
        End If
        For c1 = lc To c Step -1
            If cols(c) = cols(c1) Then cols(c1) = -2
        Next c1
    Next c
                            
End Sub

There's still one thing I can do that might speed it up, but check this out first. The main benefit is that it only reads/writes to the worksheet a minimum number of times. Which is why the borders are not working so hot - disjoint ranges don't seem to handle borders well

OK, it should copy the row colors now. I also found a bug which would have seriously affected the run time on large ranges. I'm still working on the borders. Try this out:

Sub SetHighlight()
Dim lr As Long, lc As Long, r As Long, c As Long, r1 As Long, c1 As Long
Dim rng1 As Variant, rng2 As Range, cols(1 To 1000), rowz(1 To 1000), vals(1 To 1000)

    lr = Cells(Rows.Count, "C").End(xlUp).Row - 1
    lc = Cells(8, Columns.Count).End(xlToLeft).Column
   
    Range("ZZ999").Copy Range(Range("E10"), Cells(lr, lc))
   
    For c = 5 To lc
        cols(c) = Cells(6, c).Interior.Color
        vals(c) = Cells(8, c).Value
    Next c
   
    For r = 10 To lr
        rowz(r) = Cells(r, "C").Interior.Color
    Next r
    For r = 10 To lr
        If rowz(r) > 0 Then
            Set rng2 = Nothing
            For r1 = r To lr
                If rowz(r) = rowz(r1) Then
                    If rng2 Is Nothing Then
                        Set rng2 = Range(Cells(r1, "E"), Cells(r1, lc))
                    Else
                        Set rng2 = Union(rng2, Range(Cells(r1, "E"), Cells(r1, lc)))
                    End If
                End If
            Next r1
            If Not rng2 Is Nothing Then
                rng2.Interior.Color = rowz(r)
                rng2.Borders(xlEdgeTop).LineStyle = xlContinuous
                rng2.Borders(xlEdgeBottom).LineStyle = xlContinuous
                rng2.Borders(xlInsideHorizontal).LineStyle = xlContinuous
            End If
            For r1 = lr To r Step -1
                If rowz(r) = rowz(r1) Then rowz(r1) = -2
            Next r1
        End If
    Next r
   
    rng1 = Range(Cells(10, lc + 3), Cells(lr, lc + 19)).Value
   
    On Error Resume Next
    For c = 5 To lc
        If cols(c) > 0 Then
            Set rng2 = Nothing
            For c1 = c To lc
                If cols(c1) = cols(c) Then
                    For r1 = 10 To lr
                        Err.Clear
                        x = WorksheetFunction.Match(vals(c1), WorksheetFunction.Index(rng1, r1 - 9, 0), 0)
                        If Err.Number = 0 Then
                            If rng2 Is Nothing Then
                                Set rng2 = Cells(r1, c1)
                            Else
                                Set rng2 = Union(rng2, Cells(r1, c1))
                            End If
                        End If
                    Next r1
                End If
            Next c1
            If Not rng2 Is Nothing Then
                rng2.Interior.Color = cols(c)
                rng2.Borders(xlEdgeLeft) = xlContinuous
                rng2.Borders(xlEdgeRight) = xlContinuous
                rng2.Borders(xlInsideVertical) = xlcontinous
            End If
        End If
        For c1 = lc To c Step -1
            If cols(c) = cols(c1) Then cols(c1) = -2
        Next c1
    Next c
                             
End Sub

There's still one thing I can do that might speed it up, but check this out first. The main benefit is that it only reads/writes to the worksheet a minimum number of times. Which is why the borders are not working so hot - disjoint ranges don't seem to handle borders well.

Thanks for your reply. Your help is appreciated. Codes are fine till copying the formats of rows. After that, codes are taking too much (time more than 29 mins).So i used task manager to end the excel programmer.