inefficient loop

Reggieneo · Aug 4, 2018

Dear All,
how can I make this code efficient?
its taking so much time to complete this iteration.

appreciate the help.

Code:

Sub Vba_for_clear_contentsb()
  Dim A As Long
  Dim b, c, d, e, F, g, h, i, j, k, l, n, m, 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, aq, ar, asS, at, au, av, aw
  On Error GoTo ErrorHandler
  For A = 7 To 100
  'Get some values from the sheet on the left
  'With Sheets(ActiveSheet.Index - 1)
  With Sheets("MDB")
  b = .Range("B" & A).Value
  c = .Range("C" & A).Value
  d = .Range("D" & A).Value
  e = .Range("E" & A).Value
  F = .Range("F" & A).Value
  g = .Range("G" & A).Value
  h = .Range("H" & A).Value
  i = .Range("I" & A).Value
  j = .Range("J" & A).Value
  k = .Range("K" & A).Value
  l = .Range("L" & A).Value
  m = .Range("M" & A).Value
  n = .Range("N" & A).Value
  O = .Range("O" & A).Value
  
  p = .Range("P" & A).Value
  q = .Range("Q" & A).Value
  r = .Range("R" & A).Value
  s = .Range("S" & A).Value
  t = .Range("T" & A).Value
  u = .Range("U" & A).Value
  v = .Range("V" & A).Value
  w = .Range("W" & A).Value
  X = .Range("X" & A).Value
  Y = .Range("Y" & A).Value
  z = .Range("Z" & A).Value
  aa = .Range("AA" & A).Value
  ab = .Range("AB" & A).Value
  ac = .Range("AC" & A).Value
  
  
  ad = .Range("AD" & A).Value
  ae = .Range("AE" & A).Value
  af = .Range("AF" & A).Value
  ag = .Range("AG" & A).Value
  ah = .Range("AH" & A).Value
  ai = .Range("AI" & A).Value
  aj = .Range("AJ" & A).Value
  ak = .Range("AK" & A).Value
  al = .Range("AL" & A).Value
  am = .Range("AM" & A).Value
  an = .Range("AN" & A).Value
  ao = .Range("AO" & A).Value
  ap = .Range("AP" & A).Value
  aq = .Range("AQ" & A).Value
  
  ar = .Range("AR" & A).Value
  asS = .Range("AS" & A).Value
  at = .Range("AT" & A).Value
  au = .Range("AU" & A).Value
  av = .Range("AV" & A).Value
  aw = .Range("AW" & A).Value
 
  End With
  'Check some conditions
  If (F Like "*week*") Or (F Like "*Batch*") Or (O > 1.1) Then
  'Match, write the values into this sheet
  Range("E" & A).Value = e
  Range("L" & A).Value = l
  Range("N" & A).Value = n
  
  Range("B" & A).Value = b
  Range("C" & A).Value = c
  Range("D" & A).Value = d
  Range("E" & A).Value = e
  Range("F" & A).Value = F
  Range("G" & A).Value = g
  Range("H" & A).Value = h
  Range("I" & A).Value = i
  Range("J" & A).Value = j
  Range("K" & A).Value = k
  Range("L" & A).Value = l
  Range("M" & A).Value = m
  Range("N" & A).Value = n
  Range("O" & A).Value = O
  
  Range("P" & A).Value = p
  Range("Q" & A).Value = q
  Range("R" & A).Value = r
  Range("S" & A).Value = s
  Range("T" & A).Value = t
  Range("U" & A).Value = u
  Range("V" & A).Value = v
  Range("W" & A).Value = w
  Range("X" & A).Value = X
  Range("Y" & A).Value = Y
  Range("Z" & A).Value = z
  Range("AA" & A).Value = aa
  Range("AB" & A).Value = ab
  Range("AC" & A).Value = ac
  
  Else
  'Clear the cells
  Range("B" & A).ClearContents
  Range("C" & A).ClearContents
  Range("D" & A).ClearContents
  
  Range("E" & A).ClearContents
  Range("F" & A).ClearContents
  Range("G" & A).ClearContents
  Range("H" & A).ClearContents
  Range("I" & A).ClearContents
  Range("J" & A).ClearContents
  Range("K" & A).ClearContents
  Range("L" & A).ClearContents
  Range("M" & A).ClearContents
  Range("N" & A).ClearContents
  Range("O" & A).ClearContents
  Range("P" & A).ClearContents
  Range("Q" & A).ClearContents
  Range("R" & A).ClearContents
  Range("S" & A).ClearContents
  Range("T" & A).ClearContents
  Range("U" & A).ClearContents
  Range("V" & A).ClearContents
  Range("W" & A).ClearContents
  Range("X" & A).ClearContents
  Range("Y" & A).ClearContents
  Range("Z" & A).ClearContents
  Range("AA" & A).ClearContents
  Range("AB" & A).ClearContents
  Range("AC" & A).ClearContents
  
  
  
  Range("AD" & A).ClearContents
  Range("AE" & A).ClearContents
  Range("AF" & A).ClearContents
  Range("AG" & A).ClearContents
  Range("AH" & A).ClearContents
  
  
  Range("AI" & A).ClearContents
  Range("AJ" & A).ClearContents
  Range("AK" & A).ClearContents
  Range("AL" & A).ClearContents
  Range("AM" & A).ClearContents
  
  Range("AN" & A).ClearContents
  Range("AO" & A).ClearContents
  Range("AP" & A).ClearContents
  Range("AQ" & A).ClearContents
  Range("AR" & A).ClearContents
  
  
  Range("AS" & A).ClearContents
  Range("AT" & A).ClearContents
  Range("AU" & A).ClearContents
  Range("AV" & A).ClearContents
  Range("AW" & A).ClearContents
  End If
nextrow:
  Next
  Exit Sub
ErrorHandler:
  Debug.Print "Source  : " & Err.Source
  Debug.Print "Error  : " & Err.Number
  Debug.Print "Description: " & Err.Description
  If MsgBox("Error " & Err.Number & ": " & vbNewLine & vbNewLine & _
  Err.Description & vbNewLine & vbNewLine & _
  "Enter debug mode?", vbOKCancel + vbDefaultButton2, Err.Source) = vbOK Then
  Stop 'Press F8 twice
  Resume
  Else
  Resume nextrow
  End If
 End Sub

Marc L · Aug 4, 2018

Hi !

As per forum rules, explain at least the purpose of your procedure
and join a sample workbook accordingly …

Reggieneo · Aug 4, 2018

Hello Mark,
I am trying to retain the data in the worksheet if (F column is having a text with "*week*" Or "*Batch*", or (O column > 1.1) else then the data in the entire row must be cleared.

its a huge file and my company would not allow me to attached as big as such.
hope you understand.

much thanks

vletm · Aug 4, 2018

Reggieneo
Would this work with that huge file?
I couldn't test this as You know.

Code:

Sub Vba_for_clear_contentsb()
  Dim A As Long
  Dim datas(49)
    On Error GoTo ErrorHandler
    For A = 7 To 100
  'Get some values from the sheet on the left
 'With Sheets(ActiveSheet.Index - 1)
        For X = 2 To 49
            datas(X) = Sheets("MDB").Cells(A, X)
        Next X
'Check some conditions
        If (datas(6) Like "*week*") Or (datas(6) Like "*Batch*") Or (datas(15) > 1.1) Then
'Match, write the values into this sheet
            For X = 2 To 29
                Range(A, X) = datas(X)
            Next X
        Else
'Clear the cells
            Range("B" & A & ":AW" & A).ClearContents
        End If
nextrow:
    Next
    Exit Sub
ErrorHandler:
    Debug.Print "Source  : " & Err.Source
    Debug.Print "Error  : " & Err.Number
    Debug.Print "Description: " & Err.Description
    If MsgBox("Error " & Err.Number & ": " & vbNewLine & vbNewLine & _
        Err.Description & vbNewLine & vbNewLine & _
        "Enter debug mode?", vbOKCancel + vbDefaultButton2, Err.Source) = vbOK Then
        Stop 'Press F8 twice
        Resume
    Else
        Resume nextrow
    End If
End Sub

Marc L · Aug 4, 2018

Reggieneo said:
Hello Marc,

its a huge file and my company would not allow me to attached as big as such.

In case you stay in trouble as it is very not difficult to create
a sample workbook respecting the data structure of the real one …

Reggieneo · Aug 5, 2018

Hi Vletm,
thanks for reply and code you provided.
I am getting global range failed error - runtime error 1004 in this line

Range(A, X) = datas(X)

Reggieneo · Aug 5, 2018

Hi Marc,
I have attached a sample file.
thanks

vletm · Aug 5, 2018

Reggieneo
How did You test it?
If You tested it with 'testListbox.xlsb',
then it'll give 100% errors - many!
I tried to clean only those 'duplicates'.
... and Your 'code' didn't have eg err.clear ?

Reggieneo · Aug 5, 2018

I have tested it in my currently working workbook. it gives an error right after it loops the B7. on B8 the Runtime error 1004 appears.

vletm · Aug 5, 2018

Reggieneo
I've also tested it with file, which it would work without error.
If You cannot sent even sample of file then ... challenge to find Your error.

Marc L · Aug 5, 2018

Reggieneo said:
I have attached a sample file.

Marc L said:
a sample workbook respecting the data structure of the real one …

So where is the data ?! As sample not means empty …

vletm · Aug 5, 2018

Marc L
... that file cannot be correct for sample or many things has changed!

Reggieneo · Aug 5, 2018

Hello MarcL and vletm,
sorry, I thought I upload the right file. please see the sample file.

vletm · Aug 5, 2018

Reggieneo
Yes
... there were few typos
... which could notice with real sample file.

Code:

Sub Vba_for_clear_contentsb()
  Dim A As Long
  Dim datas(49)
    On Error GoTo ErrorHandler
    For A = 7 To 100
        Err.Clear
  'Get some values from the sheet on the left
'With Sheets(ActiveSheet.Index - 1)
       For X = 2 To 49
            datas(X) = Sheets("MDB").Cells(A, X)
        Next X
'Check some conditions
       If (datas(6) Like "*week*") Or (datas(6) Like "*Batch*") Or (datas(15) > 1.1) Then
'Match, write the values into this sheet
            For X = 2 To 29
                Err.Clear
                Cells(A, X) = datas(X)
            Next X
        Else
'Clear the cells
           Range("B" & A & ":AW" & A).ClearContents
        End If
nextrow:
    Next
    Exit Sub
ErrorHandler:
    Debug.Print "Source  : " & Err.Source
    Debug.Print "Error  : " & Err.Number
    Debug.Print "Description: " & Err.Description
    If MsgBox("Error " & Err.Number & ": " & vbNewLine & vbNewLine & _
        Err.Description & vbNewLine & vbNewLine & _
        "Enter debug mode?", vbOKCancel + vbDefaultButton2, Err.Source) = vbOK Then
        Stop 'Press F8 twice
       Resume
    Else
        Resume nextrow
    End If
End Sub

Marc L · Aug 5, 2018

Reggieneo said:
please see the sample file

In case of the previous post is not the expected result then attach
an expected result workbook according to the post #13 attachment …

p45cal · Aug 5, 2018

perhaps:?

Code:

Sub Vba_for_clear_contentsb()
Dim A As Long
On Error GoTo ErrorHandler
With Sheets("MDB")
  For A = 7 To 100
    'Check some conditions
    If (.Range("F" & A).Value Like "*week*") Or (.Range("F" & A).Value Like "*Batch*") Or (.Range("O" & A).Value > 1.1) Then
      'Match, write the values into this sheet
      Range("B" & A & ":AC" & A).Value = .Range("B" & A & ":AC" & A).Value
    Else
      'Clear the cells
      Range("B" & A & ":AW" & A).ClearContents
    End If
nextrow:
  Next
End With
Exit Sub


ErrorHandler:
Debug.Print "Source  : " & Err.Source
Debug.Print "Error  : " & Err.Number
Debug.Print "Description: " & Err.Description
If MsgBox("Error " & Err.Number & ": " & vbNewLine & vbNewLine & _
          Err.Description & vbNewLine & vbNewLine & _
          "Enter debug mode?", vbOKCancel + vbDefaultButton2, Err.Source) = vbOK Then
  Stop    'Press F8 twice
  Resume
Else
  Resume nextrow
End If
End Sub

Reggieneo · Aug 6, 2018

p45cal,
it worked! thanks.

Marc L, vletm,
thanks for your patience.

inefficient loop

Reggieneo

Member

Marc L

Excel Ninja

Reggieneo

Member

vletm

Excel Ninja

Marc L

Excel Ninja

Reggieneo

Member

Reggieneo

Member

Attachments

vletm

Excel Ninja

Reggieneo

Member

vletm

Excel Ninja

Marc L

Excel Ninja

vletm

Excel Ninja

Reggieneo

Member

Attachments

vletm

Excel Ninja

Marc L

Excel Ninja

p45cal

Well-Known Member

Reggieneo

Member