Excel is slow with VBA code - kindly check VBA codes below

T

Thilan

New Member
Joined
Jul 13, 2021
Messages
10
Office Version
  1. 2016
Platform
  1. Windows
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Changed As Range, c As Range
  Dim sCleared As String
  Set Changed = Intersect(Target, Union(Range("D29:AH40,D50:AH61,D71:AH82,D92:AH103,D113:AH124,D134:AH145,D155:AH166,D176:AH187,D197:AH208,D218:AH229,D239:AH250,D260:AH271,D281:AH292,D302:AH313,D323:AH334,D344:AH355,D365:AH376,D386:AH397,D407:AH418,D428:AH439,D449:AH460,D470:AH481,D491:AH502"), Range("D512:AH523,D533:AH544,D554:AH565,D575:AH586,D596:AH608,D617:AH628")))
  If Not Changed Is Nothing Then
    Application.EnableEvents = False
    For Each c In Changed
      Select Case c.Value
        Case "JAV", "VAC", "vac", "jav", "AB", "DO", "SL", "CV", "DT", "EX", "MT", "NJ", "PV", "RN", "SL", "UM", "UP", "LD", "TF", "ab", "do", "cv", "dt", "ex", "mt", "nj", "pv", "rn", "sl", "um", "up", "ld", "tf", -10 To 20
   
      Union(Range("D29:AH40,D50:AH61,D71:AH82,D92:AH103,D113:AH124,D134:AH145,D155:AH166,D176:AH187,D197:AH208,D218:AH229,D239:AH250,D260:AH271,D281:AH292,D302:AH313,D323:AH334,D344:AH355,D365:AH376,D386:AH397,D407:AH418,D428:AH439,D449:AH460,D470:AH481,D491:AH502"), Range("D512:AH523,D533:AH544,D554:AH565,D575:AH586,D596:AH608,D617:AH628")).Borders.LineStyle = xlContinuous
        Case Else
          sCleared = sCleared & vbLf & c.Address(0, 0) & " (" & c.Value & ")"
          c.ClearContents
      Union(Range("D29:AH40,D50:AH61,D71:AH82,D92:AH103,D113:AH124,D134:AH145,D155:AH166,D176:AH187,D197:AH208,D218:AH229,D239:AH250,D260:AH271,D281:AH292,D302:AH313,D323:AH334,D344:AH355,D365:AH376,D386:AH397,D407:AH418,D428:AH439,D449:AH460,D470:AH481,D491:AH502"), Range("D512:AH523,D533:AH544,D554:AH565,D575:AH586,D596:AH608,D617:AH628")).Borders.LineStyle = xlContinuous

      End Select
    Next c
   
  End If

  If Target.HasFormula Then Exit Sub
        Application.EnableEvents = False
        Target = UCase(Target.Cells(1))
    Application.EnableEvents = True
  
For Each cell In Union(Range("D29:AH40,D50:AH61,D71:AH82,D92:AH103,D113:AH124,D134:AH145,D155:AH166,D176:AH187,D197:AH208,D218:AH229,D239:AH250,D260:AH271,D281:AH292,D302:AH313,D323:AH334,D344:AH355,D365:AH376,D386:AH397,D407:AH418,D428:AH439,D449:AH460,D470:AH481,D491:AH502"), Range("D512:AH523,D533:AH544,D554:AH565,D575:AH586,D596:AH608,D617:AH628"))
If cell.Value = "DO" Then

cell.Interior.Color = XlRgbColor.rgbLightGreen

Else

cell.Interior.Color = xlNone

End If
Next

Union(Range("D29:AH40,D50:AH61,D71:AH82,D92:AH103,D113:AH124,D134:AH145,D155:AH166,D176:AH187,D197:AH208,D218:AH229,D239:AH250,D260:AH271,D281:AH292,D302:AH313,D323:AH334,D344:AH355,D365:AH376,D386:AH397,D407:AH418,D428:AH439,D449:AH460,D470:AH481,D491:AH502"), Range("D512:AH523,D533:AH544,D554:AH565,D575:AH586,D596:AH608,D617:AH628")).Borders.LineStyle = xlContinuous
Union(Range("b29:b40,b50:b61,b71:b82,b92:b103,b113:b124,b134:b145,b155:b166,b176:b187,b197:b208,b218:b229,b239:b250,b260:b271,b281:b292,b302:b313,b323:b334,b344:b355,b365:b376,b386:b397,b407:b418,b428:b439,b449:b460,b470:b481,b491:b502"), Range("b512:b523,b533:b544,b554:b565,b575:b586,b596:b608,b617:b628")).Borders.LineStyle = xlContinuous

    Application.EnableEvents = False
    For Each cell In Target
        If Not Application.Intersect(cell, Union(Range("b29:b40,b50:b61,b71:b82,b92:b103,b113:b124,b134:b145,b155:b166,b176:b187,b197:b208,b218:b229,b239:b250,b260:b271,b281:b292,b302:b313,b323:b334,b344:b355,b365:b376,b386:b397,b407:b418,b428:b439,b449:b460,b470:b481,b491:b502"), Range("b512:b523,b533:b544,b554:b565,b575:b586,b596:b608,b617:b628"))) Is Nothing Then
           If Not IsNumeric(cell.Value) Then

              cell.Value = vbNullString
 
              Union(Range("b29:b40,b50:b61,b71:b82,b92:b103,b113:b124,b134:b145,b155:b166,b176:b187,b197:b208,b218:b229,b239:b250,b260:b271,b281:b292,b302:b313,b323:b334,b344:b355,b365:b376,b386:b397,b407:b418,b428:b439,b449:b460,b470:b481,b491:b502"), Range("b512:b523,b533:b544,b554:b565,b575:b586,b596:b608,b617:b628")).Borders.LineStyle = xlContinuous
   
           End If
        End If
    Next cell
    Application.EnableEvents = True
  
End Sub
 
Last edited by a moderator:

Excel Facts

Whats the difference between CONCAT and CONCATENATE?
The newer CONCAT function can reference a range of cells. =CONCATENATE(A1,A2,A3,A4,A5) becomes =CONCAT(A1:A5)
Sort by date Sort by votes
Maybe this (not tested)

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Changed As Range, c As Range, cell As Range, CellRange1 As Range, CellRange2 As Range
    'Dim sCleared As String
    
    Application.ScreenUpdating = False
    Set CellRange1 = Union(Range("D29:AH40,D50:AH61,D71:AH82,D92:AH103,D113:AH124,D134:AH145,D155:AH166,D176:AH187,D197:AH208,D218:AH229,D239:AH250,D260:AH271,D281:AH292,D302:AH313,D323:AH334,D344:AH355,D365:AH376,D386:AH397,D407:AH418,D428:AH439,D449:AH460,D470:AH481,D491:AH502"), Range("D512:AH523,D533:AH544,D554:AH565,D575:AH586,D596:AH608,D617:AH628"))
    CellRange1.Borders.LineStyle = xlContinuous
    
    Set Changed = Intersect(Target, CellRange1)
    If Not Changed Is Nothing Then
        Application.EnableEvents = False
        For Each c In Changed
            Select Case c.Value
                Case "JAV", "VAC", "vac", "jav", "AB", "DO", "SL", "CV", "DT", "EX", "MT", "NJ", "PV", "RN", "SL", "UM", "UP", "LD", "TF", "ab", "do", "cv", "dt", "ex", "mt", "nj", "pv", "rn", "sl", "um", "up", "ld", "tf", -10 To 20
                Case Else
                    'sCleared = sCleared & vbLf & c.Address(0, 0) & " (" & c.Value & ")" 'string sCleared is not used anywhere else in the sub
                    c.ClearContents
            End Select
        Next c
        Application.EnableEvents = True
    End If
    
    If Target.HasFormula Then Exit Sub
    
    Application.EnableEvents = False
    Target = UCase(Target.Cells(1))
    
    CellRange1.Interior.Color = xlNone
    For Each cell In CellRange1
        If cell.Value = "DO" Then
            cell.Interior.Color = XlRgbColor.rgbLightGreen
        End If
    Next cell
    Application.EnableEvents = True
    
    Set CellRange2 = Union(Range("b29:b40,b50:b61,b71:b82,b92:b103,b113:b124,b134:b145,b155:b166,b176:b187,b197:b208,b218:b229,b239:b250,b260:b271,b281:b292,b302:b313,b323:b334,b344:b355,b365:b376,b386:b397,b407:b418,b428:b439,b449:b460,b470:b481,b491:b502"), Range("b512:b523,b533:b544,b554:b565,b575:b586,b596:b608,b617:b628"))
    CellRange2.Borders.LineStyle = xlContinuous
    
    Application.EnableEvents = False
    For Each cell In Target
        If Not Application.Intersect(cell, CellRange2) Is Nothing Then
            If Not IsNumeric(cell.Value) Then
                cell.Value = vbNullString
            End If
        End If
    Next cell
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution
If you replace some of your Long Union lines with something like this, does that help at all?
Code: 
Dim i As Long
    For i = 29 To 617 Step 21
        Application.Union(Cells(i, 2).Resize(12, 1), Cells(i, 4).Resize(12, 31)).Borders.LineStyle = xlContinuous
    Next i
 
Upvote 0
Or explain in a concise manner what you try to achieve.
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,214,819
Messages
6,121,746
Members
449,050
Latest member
excelknuckles

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top