Help me optimize this code to run faster

Z

zeljko_88

New Member
Joined
May 22, 2013
Messages
2
I have a code that uses excel web queries to retrieve data from a web site.
The query part is optimized but the rest of the code with a lot of If statements makes it run slow.
Please help.
Here is the code:
Code: 
Sub datta()


 Application.DisplayAlerts = False
   Application.Calculation = xlCalculationManual
       Application.ScreenUpdating = True
       
    Dim RowNo, lastRowNo As Long
    Dim emptyRow As Integer
   
    Dim pageNo, lastPageNo As Integer
    
    Dim rowcount As Integer
   
    Dim lastrow, lastrowQuery As Long
    Dim url As String
    Dim rezultat() As Variant
    Dim pocetak_nutrition As Long
    
    Dim serving_size, Serving_per_Container, Calories, Calories_from_fat, Total_Fat, Saturated_Fat, _
Trans_Fat, Cholesterol, Sodium, Total_Carbohydrate, Fiber, Sugars, Protein, Vitamin_A, Calcium, category As String
Dim product_name, sku, description, origin, ingredients As String
Dim Total_FatPercent, Saturated_FatPercent, Cholesterol_percent, Sodium_percent, Total_Carbohydrate_perce, _
Fiber_perce, Vitamin_A_perce, Calcium_perce As String
    
lastrow = Sheet7.Range("a2").End(xlDown).Row


Dim skup_linkova() As Variant
skup_linkova = Sheet7.Range("a2:a4740")
  
 For pageNo = 852 To UBound(skup_linkova) 'lastrow
 serving_size = vbNullString
 Serving_per_Container = vbNullString
 Calcium = vbNullString
 Calcium_perce = vbNullString
 Calories = vbNullString
 Calories_from_fat = vbNullString
  Total_Carbohydrate = vbNullString
  Total_Carbohydrate_perce = vbNullString
  Total_Fat = vbNullString
  Total_FatPercent = vbNullString
  Trans_Fat = vbNullString
  Fiber = vbNullString
  Fiber_perce = vbNullString
  Cholesterol = vbNullString
  Cholesterol_percent = vbNullString
  ingredients = vbNullString
  product_name = vbNullString
  sku = vbNullString
  origin = vbNullString
  category = vbNullString
   description = vbNullString
   Vitamin_A = vbNullString
   Vitamin_A_perce = vbNullString
   Sodium = vbNullString
   Sodium_percent = vbNullString
 Saturated_Fat = vbNullString
 Saturated_FatPercent = vbNullString
 Sugars = vbNullString
 Protein = vbNullString
 
 
 url = skup_linkova(pageNo, 1) 'Sheet7.Cells(pageNo, 1)
 
 'Application.Wait (Now + TimeValue("0:00:02"))
 


Call Macro6(url)


lastrowQuery = Sheet5.Cells.SpecialCells(xlCellTypeLastCell).Row






product_name = CStr(Sheet5.Cells(115, 1).Value)
sku = CStr(Sheet5.Cells(116, 1).Value)
description = CStr(Sheet5.Cells(117, 1).Value)




For i = lastrowQuery To 117 Step -1




If InStr(1, Sheet5.Cells(i, 1).Value, "Country of Origin:") > 0 Then
    origin = CStr(Replace(Sheet5.Cells(i, 1).Value, "Country of Origin:", ""))


End If


If ingredients = "" Then
    If Sheet5.Cells(i, 1).Value = "Ingredients" And Len(Sheet5.Cells(i + 2, 1).Value) > 80 Then
        ingredients = CStr(Sheet5.Cells(i + 2, 1).Value)


    End If
End If
'nutritions




If serving_size = "" Then
    If InStr(1, Sheet5.Cells(i, 1).Value, "Serving Size ") > 0 And InStr(1, Sheet5.Cells(i, 1).Value, "Ingredients") = 0 Then
        serving_size = Replace(CStr(Sheet5.Cells(i, 1).Value), "Serving Size", "")


    End If
End If


If Serving_per_Container = "" Then
    If InStr(1, Sheet5.Cells(i, 1).Value, "Servings per Container") > 0 And InStr(1, Sheet5.Cells(i, 1).Value, "Ingredients") = 0 Then
        Serving_per_Container = Replace(CStr(Sheet5.Cells(i, 1).Value), "Servings per Container", "")


    End If
End If


If Calories = "" Then
    If InStr(1, Sheet5.Cells(i, 1).Value, "Calories") > 0 And InStr(1, Sheet5.Cells(i, 1).Value, "Ingredients") = 0 Then
        Calories = Replace(CStr(Sheet5.Cells(i, 1).Value), "Calories", "")
        Calories_from_fat = Replace(CStr(Sheet5.Cells(i, 3).Value), "Calories from Fat", "")
    End If
End If


If Total_Fat = "" Then
    If InStr(1, Sheet5.Cells(i, 1).Value, "Total Fat") > 0 And InStr(1, Sheet5.Cells(i, 1).Value, "Ingredients") = 0 Then
        Total_Fat = Replace(CStr(Sheet5.Cells(i, 1).Value), "Total Fat ", "")
       Total_FatPercent = CStr(Sheet5.Cells(i, 3).Value)
    End If
End If






If Saturated_Fat = "" Then
    If InStr(1, Sheet5.Cells(i, 1).Value, "Saturated Fat") > 0 And InStr(1, Sheet5.Cells(i, 1).Value, "Ingredients") = 0 Then
        Saturated_Fat = Replace(CStr(Sheet5.Cells(i, 1).Value), "Saturated Fat ", "")
       Saturated_FatPercent = CStr(Sheet5.Cells(i, 3).Value)
    End If
End If


If Trans_Fat = "" Then
    If InStr(1, Sheet5.Cells(i, 1).Value, "Trans Fat ") > 0 And InStr(1, Sheet5.Cells(i, 1).Value, "Ingredients") = 0 Then
        Trans_Fat = Replace(CStr(Sheet5.Cells(i, 1).Value), "Trans Fat ", "")
       
    End If
End If




If Cholesterol = "" Then
    If InStr(1, Sheet5.Cells(i, 1).Value, "Cholesterol") > 0 And InStr(1, Sheet5.Cells(i, 1).Value, "Ingredients") = 0 Then
        Cholesterol = Replace(CStr(Sheet5.Cells(i, 1).Value), "Cholesterol", "")
       Cholesterol_percent = CStr(Sheet5.Cells(i, 3).Value)
    End If
End If


If Sodium = "" Then
    If InStr(1, Sheet5.Cells(i + 3, 1).Value, "Sodium ") > 0 And InStr(1, Sheet5.Cells(i + 3, 1).Value, "Ingredients") = 0 Then
        Sodium = Replace(CStr(Sheet5.Cells(i + 3, 1).Value), "Sodium", "")
      Sodium_percent = CStr(Sheet5.Cells(i + 3, 3).Value)
    End If
End If


If Total_Carbohydrate = "" Then
    If InStr(1, Sheet5.Cells(i, 1).Value, "Total Carbohydrate ") > 0 And InStr(1, Sheet5.Cells(i, 1).Value, "Ingredients") = 0 Then
        Total_Carbohydrate = Replace(CStr(Sheet5.Cells(i, 1).Value), "Total Carbohydrate ", "")
      Total_Carbohydrate_perce = CStr(Sheet5.Cells(i, 3).Value)
    End If
End If


If Fiber = "" Then
    If InStr(1, Sheet5.Cells(i, 1).Value, "Fiber") > 0 And InStr(1, Sheet5.Cells(i, 1).Value, "Ingredients") = 0 Then
        Fiber = Replace(CStr(Sheet5.Cells(i, 1).Value), "Fiber", "")
      Fiber_perce = CStr(Sheet5.Cells(i, 3).Value)
    End If
End If




If Sugars = "" Then
    If InStr(1, Sheet5.Cells(i, 1).Value, "Sugars ") > 0 And InStr(1, Sheet5.Cells(i, 1).Value, "Ingredients") = 0 Then
        Sugars = Replace(CStr(Sheet5.Cells(i, 1).Value), "Sugars ", "")
     ' Fiber_perce = CStr(Sheet5.Cells(i, 3).Value)
    End If
End If


If Protein = "" Then
    If InStr(1, Sheet5.Cells(i, 1).Value, "Protein ") > 0 And InStr(1, Sheet5.Cells(i, 1).Value, "Ingredients") = 0 Then
        Protein = Replace(CStr(Sheet5.Cells(i, 1).Value), "Protein ", "")
     ' Fiber_perce = CStr(Sheet5.Cells(i, 3).Value)
    End If
End If


If Vitamin_A = "" Then
    If InStr(1, Sheet5.Cells(i, 1).Value, "Vitamin A") > 0 And InStr(1, Sheet5.Cells(i, 1).Value, "Ingredients") = 0 Then
        Vitamin_A = Replace(CStr(Sheet5.Cells(i, 1).Value), "Vitamin A", "")
     Vitamin_A_perce = Replace(CStr(Sheet5.Cells(i, 3).Value), "Vitamin C", "")
    End If
End If


If Calcium = "" Then
    If InStr(1, Sheet5.Cells(i, 1).Value, "Calcium ") > 0 And InStr(1, Sheet5.Cells(i, 1).Value, "Ingredients") = 0 Then
       Calcium = Replace(CStr(Sheet5.Cells(i, 1).Value), "Calcium ", "")
     Calcium_perce = Replace(CStr(Sheet5.Cells(i, 3).Value), "Iron ", "")
    End If
End If




Next










If product_name = "" Then
product_name = vbNullString
ElseIf sku = "" Then
sku = vbNullString
ElseIf description = "" Then
description = vbNullString
ElseIf origin = "" Then
origin = vbNullString
ElseIf ingredients = "" Then
ingredients = ""
End If






category = Mid(url, 41, GetPositionOfFirstNumericCharacter(url) - 41)




rezultat = Array(category, product_name, sku, description, origin, ingredients, serving_size, Serving_per_Container, Calories, Calories_from_fat, Total_Fat, Total_FatPercent, Saturated_Fat, Saturated_FatPercent, Cholesterol, Cholesterol_percent, Sodium, Sodium_percent, Total_Carbohydrate, Total_Carbohydrate_perce, Fiber, Fiber_perce, Sugars, Protein, Vitamin_A, Vitamin_A_perce, Calcium, Calcium_perce)


emptyRow = pageNo


Sheet4.Range("a" & emptyRow & ":ab" & emptyRow) = rezultat










Call brisi_query
  
  'Exit Sub
   Next pageNo
   
'   Sheet7.Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
   
   lastrowDATA = Sheet7.Range("a2").End(xlDown).Row
   
    Sheet7.Range("$A$1:$B$" & lastrowDATA).RemoveDuplicates Columns:=Array(1, 2), _
        Header:=xlYes
   
    'Range("A21").Select
    'On Error Resume Next


Application.DisplayAlerts = True
   Application.Calculation = xlCalculationAutomatic
       Application.ScreenUpdating = True


End Sub




Public Function GetPositionOfFirstNumericCharacter(ByVal s As String) As Integer
    For i = 1 To Len(s)
        Dim currentCharacter As String
        currentCharacter = Mid(s, i, 1)
        If IsNumeric(currentCharacter) = True Then
            GetPositionOfFirstNumericCharacter = i
            Exit Function
        End If
    Next i
End Function
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
You must log in or register to reply here.

Similar threads

T
  • Question Question
This is so slow I have to run it overnight
Replies
4
Views
425
kevin9999
K
ChristineJ
  • Question Question
Function rather than macro to return cell references
Replies
3
Views
334
Micron
M
afrazier1221
  • Solved
VBA adding symbols, disabling the intended code. Please help.
Replies
1
Views
501
afrazier1221
afrazier1221
ChristineJ
  • Solved
Adapting code to return cell values rather than cell references
Replies
2
Views
375
ChristineJ
ChristineJ
K
  • Question Question
Can you please explain why this code getting error while running
Replies
2
Views
225
Joe4
Joe4

Forum statistics

Threads
1,223,227
Messages
6,170,848
Members
452,361
Latest member
d3ad3y3

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