VBA code improvement

effka

New Member
Joined
Mar 31, 2022
Messages
20
Office Version
  1. 2021
Platform
  1. Windows
Hello,

I have a code for deleting unnecessary data in my excel tables (all in same sheet):
VBA Code:
Sub delete_data()

    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.DisplayStatusBar = False
    ActiveSheet.DisplayPageBreaks = False
    Application.Calculation = xlCalculationManual

    Dim cell As Range
    Dim rng As Range
   
'delete first site of data1
    With ActiveSheet
        For Each cell In .Range("D1:D263,CL1:CL263,FT1:FT263,JB1:JB263,MJ1:MJ263,PR1:PR263,SZ1:SZ263,WH1:WH263,ZP1:ZP263,ACX1:ACX263,AGF1:AGF263,AJN1:AJN263,AMV1:AMV263,AQD1:AQD263,ATL1:ATL263,AWT1:AWT263,BAB1:BAB263")
            If cell.Value = "criteria No. 1" Then
                Set rng = cell
                .Range(Cells(rng.Row - 1, rng.Column + 3), Cells(rng.Row + 3, rng.Column + 62)).Value = ""
            End If
        Next cell
    End With
'delete first site of data2
    With ActiveSheet
        For Each cell In .Range("BDJ1:BDJ263,BGR1:BGR263,BJZ1:BJZ263,BNH1:BNH263,BQP1:BQP263,BTX1:BTX263,BXF1:BXF263,CAN1:CAN263,CDV1:CDV263,CHD1:CHD263,CKL1:CKL263,CNT1:CNT263,CRB1:CRB263,CUJ1:CUJ263")
            If cell.Value = "criteria No. 1" Then
                Set rng = cell
                .Range(Cells(rng.Row - 1, rng.Column + 3), Cells(rng.Row + 3, rng.Column + 62)).Value = ""
            End If
        Next cell
    End With
   
'delete second site of data1
With ActiveSheet
        For Each cell In .Range("D1:D263,CL1:CL263,FT1:FT263,JB1:JB263,MJ1:MJ263,PR1:PR263,SZ1:SZ263,WH1:WH263,ZP1:ZP263,ACX1:ACX263,AGF1:AGF263,AJN1:AJN263,AMV1:AMV263,AQD1:AQD263,ATL1:ATL263,AWT1:AWT263,BAB1:BAB263")
            If cell.Value = "criteria No. 2" Then
                Set rng = cell
                .Range(Cells(rng.Row + 1, rng.Column + 3), Cells(rng.Row + 6, rng.Column + 62)).Value = ""
            End If
        Next cell
    End With
'delete second site of data2
With ActiveSheet
        For Each cell In .Range("BDJ1:BDJ263,BGR1:BGR263,BJZ1:BJZ263,BNH1:BNH263,BQP1:BQP263,BTX1:BTX263,BXF1:BXF263,CAN1:CAN263,CDV1:CDV263,CHD1:CHD263,CKL1:CKL263,CNT1:CNT263,CRB1:CRB263,CUJ1:CUJ263")
            If cell.Value = "criteria No. 2" Then
                Set rng = cell
                .Range(Cells(rng.Row + 1, rng.Column + 3), Cells(rng.Row + 6, rng.Column + 62)).Value = ""
            End If
        Next cell
    End With
   
'copy/paste third site of data1
With ActiveSheet
        For Each cell In .Range("D1:D263,CL1:CL263,FT1:FT263,JB1:JB263,MJ1:MJ263,PR1:PR263,SZ1:SZ263,WH1:WH263,ZP1:ZP263,ACX1:ACX263,AGF1:AGF263,AJN1:AJN263,AMV1:AMV263,AQD1:AQD263,ATL1:ATL263,AWT1:AWT263,BAB1:BAB263")
            If cell.Value = "criteria No. 2" Then
                Set rng = cell
                Range("D1:BK1").Copy
                .Range(Cells(rng.Row, rng.Column + 3), Cells(rng.Row, rng.Column + 62)).PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False
            End If
        Next cell
    End With
'copy/paste third site of data2
With ActiveSheet
        For Each cell In .Range("BDJ1:BDJ263,BGR1:BGR263,BJZ1:BJZ263,BNH1:BNH263,BQP1:BQP263,BTX1:BTX263,BXF1:BXF263,CAN1:CAN263,CDV1:CDV263,CHD1:CHD263,CKL1:CKL263,CNT1:CNT263,CRB1:CRB263,CUJ1:CUJ263")
            If cell.Value = "criteria No. 2" Then
                Set rng = cell
                Range("D1:BK1").Copy
                .Range(Cells(rng.Row, rng.Column + 3), Cells(rng.Row, rng.Column + 62)).PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False
            End If
        Next cell
    End With
   
'copy/paste fourth site of data1
With ActiveSheet
        For Each cell In .Range("D1:D263,CL1:CL263,FT1:FT263,JB1:JB263,MJ1:MJ263,PR1:PR263,SZ1:SZ263,WH1:WH263,ZP1:ZP263,ACX1:ACX263,AGF1:AGF263,AJN1:AJN263,AMV1:AMV263,AQD1:AQD263,ATL1:ATL263,AWT1:AWT263,BAB1:BAB263")
            If cell.Value = "criteria No. 3" Then
                Set rng = cell
                Range("D2:BK2").Copy
                .Range(Cells(rng.Row, rng.Column + 3), Cells(rng.Row, rng.Column + 62)).PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False
            End If
        Next cell
    End With
'copy/paste fourth site of data2
With ActiveSheet
        For Each cell In .Range("BDJ1:BDJ263,BGR1:BGR263,BJZ1:BJZ263,BNH1:BNH263,BQP1:BQP263,BTX1:BTX263,BXF1:BXF263,CAN1:CAN263,CDV1:CDV263,CHD1:CHD263,CKL1:CKL263,CNT1:CNT263,CRB1:CRB263,CUJ1:CUJ263")
            If cell.Value = "criteria No. 3" Then
                Set rng = cell
                Range("D2:BK2").Copy
                .Range(Cells(rng.Row, rng.Column + 3), Cells(rng.Row, rng.Column + 62)).PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False
            End If
        Next cell
    End With

'Delete fifth site of data1
    With ActiveSheet
        For Each cell In .Range("D1:D263,CL1:CL263,FT1:FT263,JB1:JB263,MJ1:MJ263,PR1:PR263,SZ1:SZ263,WH1:WH263,ZP1:ZP263,ACX1:ACX263,AGF1:AGF263,AJN1:AJN263,AMV1:AMV263,AQD1:AQD263,ATL1:ATL263,AWT1:AWT263,BAB1:BAB263")
            If cell.Value = "criteria No. 4" Then
                Set rng = cell
                .Range(Cells(rng.Row, rng.Column + 3), Cells(rng.Row, rng.Column + 62)).Value = ""
            End If
        Next cell
    End With
'Delete fifth site of data2
    With ActiveSheet
        For Each cell In .Range("BDJ1:BDJ263,BGR1:BGR263,BJZ1:BJZ263,BNH1:BNH263,BQP1:BQP263,BTX1:BTX263,BXF1:BXF263,CAN1:CAN263,CDV1:CDV263,CHD1:CHD263,CKL1:CKL263,CNT1:CNT263,CRB1:CRB263,CUJ1:CUJ263")
            If cell.Value = "criteria No. 4" Then
                Set rng = cell
                .Range(Cells(rng.Row, rng.Column + 3), Cells(rng.Row, rng.Column + 62)).Value = ""
            End If
        Next cell
    End With

'othe data reset
        Range("D49").Value = "MT"
        Range("D50").Value = ""
        Range("D51").Value = ""
        Range("D52").Value = "L-"
        Range("D53").Value = "230"
        Range("D55").Value = "100 mm"
        Range("B47").Activate
        Application.Goto ActiveCell, Scroll:=True

    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.DisplayStatusBar = True
    ActiveSheet.DisplayPageBreaks = True
    Calculate
    Application.Calculation = xlCalculationAutomatic
   
End Sub

All criteria are in same column, and first column number is 4 ("D") and other columns differ every 86 columns (for example: second column is 4+86= 90 column "CL"). There are 31 tables in total, so 31 columns.

Can you help me to simplify my huge code? I tried to create loop for all those columns, didn't worked :/
 

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
Hi effka,

something like

VBA Code:
Sub delete_data_mod()
' https://www.mrexcel.com/board/threads/vba-code-improvement.1226476/
  Dim rngCell As Range
  Dim lngCnt As Long
  
  With Application
    .ScreenUpdating = False
    .DisplayStatusBar = False
    .DisplayPageBreaks = False
    .Calculation = xlCalculationManual
  End With
  
  With ActiveSheet
    For lngCnt = 4 To (4 + 30 * 86) Step 86
      For Each rngCell In .Range(.Cells(1, lngCnt), .Cells(263, lngCnt))
        If rngCell.Value = "criteria No. 1" Then
          .Range(.Cells(rngCell.Row - 1, lngCnt + 3), .Cells(rngCell.Row + 3, lngCnt + 62)).Value = ""
          End If
      Next rngCell
    Next lngCnt
  End With
  
  'other data reset
  .Range("D49").Value = "MT"
  .Range("D50:D51").Value = ""
  .Range("D52").Value = "L-"
  .Range("D53").Value = "230"
  .Range("D55").Value = "100 mm"
  .Range("B47").Activate
  
  With Application
    .Goto .ActiveCell, Scroll:=True
  
    .ScreenUpdating = True
    .DisplayStatusBar = True
    .DisplayStatusBar = True
    ActiveSheet.DisplayPageBreaks = True
    .Calculation = xlCalculationAutomatic
    Calculate
  End With
End Sub

The first row cannot show the criteria as that would lead to a run-time error (row1 - 1 does not exist).

Ciao,
Holger
 
Upvote 0
Solution
Hi effka,

something like

VBA Code:
Sub delete_data_mod()
' https://www.mrexcel.com/board/threads/vba-code-improvement.1226476/
  Dim rngCell As Range
  Dim lngCnt As Long
 
  With Application
    .ScreenUpdating = False
    .DisplayStatusBar = False
    .DisplayPageBreaks = False
    .Calculation = xlCalculationManual
  End With
 
  With ActiveSheet
    For lngCnt = 4 To (4 + 30 * 86) Step 86
      For Each rngCell In .Range(.Cells(1, lngCnt), .Cells(263, lngCnt))
        If rngCell.Value = "criteria No. 1" Then
          .Range(.Cells(rngCell.Row - 1, lngCnt + 3), .Cells(rngCell.Row + 3, lngCnt + 62)).Value = ""
          End If
      Next rngCell
    Next lngCnt
  End With
 
  'other data reset
  .Range("D49").Value = "MT"
  .Range("D50:D51").Value = ""
  .Range("D52").Value = "L-"
  .Range("D53").Value = "230"
  .Range("D55").Value = "100 mm"
  .Range("B47").Activate
 
  With Application
    .Goto .ActiveCell, Scroll:=True
 
    .ScreenUpdating = True
    .DisplayStatusBar = True
    .DisplayStatusBar = True
    ActiveSheet.DisplayPageBreaks = True
    .Calculation = xlCalculationAutomatic
    Calculate
  End With
End Sub

The first row cannot show the criteria as that would lead to a run-time error (row1 - 1 does not exist).

Ciao,
Holger
thank you, worked very well!
 
Upvote 0

Forum statistics

Threads
1,223,911
Messages
6,175,326
Members
452,635
Latest member
laura12345

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