VBA code improvement

E

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

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Sort by date Sort by votes
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
HaHoBe said:
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
Click to expand...
thank you, worked very well!
 
Upvote 0
You must log in or register to reply here.

Similar threads

mehidy1437
  • Question Question
Requesting for experts comments suggestion on my vba code
Replies
5
Views
894
mehidy1437
mehidy1437
M
  • Question Question
vba code to split cells that contain "*" and do nothing with cells that do not contain "*"
Replies
4
Views
1K
Trebor76
T
Johnny Thunder
  • Question Question
VBa Help - For Each & .Printout Code failing on my List of Sheets
Replies
8
Views
697
Johnny Thunder
Johnny Thunder
2
  • Question Question
VBA modification
Replies
0
Views
385
231tony231
2
K
  • Locked
  • Question Question
VBA Sum Multiple Columns and Duplicate Rows
Replies
6
Views
9K
Fluff
Fluff

Forum statistics

Threads
1,224,828
Messages
6,181,212
Members
453,023
Latest member
alabaz

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