VBA and Excel optimization of processing time, dealing with several rows

Question

Hello StackOverflowers,

I need som help here.

I have been working on a VBA code but it is taking around 20 to 30 mins to process the data and I need some advise to reduce the amount the processing time.

I have 3 sheets in the document.

1- Sheet 1 is called "ExtractData".

That sheet contains 3 columns:

Column A: contains "Environment: PROD, Pre-Prod & UAT", responsible fetching the data based on the environment stated in the dropdown list. That column contains also a possibility to parse the html text contained in some cells

Column B: Contain list of Product Code

Column C: contains name of fields / attribute for which we need the data for.

Also, we have a button in that sheet that should run the code to fetch the data and display them in sheet called "Source Data"

2- Sheet 2: Called "DataReview", containing extracted data, then I copy data content from cell A2:MJ500 and paste it in sheet 3 (Source Data) that contains some predefined headers. So I paste data from A4

3- Sheet 3 called: "Source Data"

That sheet will display all data fetched based on the stated attribute

CASE 1: What I am supposed to do, is to filter the data based on some variable and transpose them in a separate sheet:

Exemple 1: May via a VBA buttong, I select specific attribute, like filter based on "Product Family", when you click run, it will copy the data, then transpose them in a specific way in a separate sheet named after the Product family name

BUT, I tried, different ways and I am not getting what I wanted.

Below find the code I am using, please go through it and help me make it better.

Function Get_File(Enviromment As String, Pos_row As Integer, Data_date As String) As String

Dim objRequest As Object
Dim blnAsync As Boolean
Dim strResponse As String
Dim Token As String
Dim Url As String
Dim No_product_string As String



Token = "xxxxxxxx"

Url = CreateURL(Enviromment, Pos_row, Data_date)

Set objRequest = CreateObject("MSXML2.XMLHTTP")

blnAsync = True

With objRequest
    .Open "GET", Url, blnAsync
    .SetRequestHeader "Content-Type", "application/json"
    .SetRequestHeader "x-auth-token", "xxxxxxxx"
    .Send
    'spin wheels whilst waiting for response
    While objRequest.ReadyState <> 4
        DoEvents
    Wend
    strResponse = .ResponseText
End With

Debug.Print strResponse


Get_File = strResponse



End Function

Function CreateURL(Enviroment As String, Pos_row As Integer, Data_date As String)
Dim product_code As String



If (StrComp(Enviroment, "UAT", vbTextCompare) = 0) Then
    CreateURL = "https://TEST1-uat.Nothing.net:8096/api/products/hierarchies"
ElseIf (StrComp(Enviroment, "PPROD", vbTextCompare) = 0) Then
    CreateURL = "https://TEST1-pprod.nothing.net:8096/api/products/hierarchies"
ElseIf (StrComp(Enviroment, "PROD", vbTextCompare) = 0) Then
    CreateURL = "https://TEST1.nothing.net:8096/api/products/hierarchies"
Else
    CreateURL = "https://TEST1.nothing.net:8096/api/products/hierarchies"
End If

If Pos_row <> -1 Then
    product_code = ThisWorkbook.Sheets("DataReview").Cells(Pos_row, 1)
    CreateURL = CreateURL & "?query=%7B%22productCode%22%3A%22" & product_code & "%22%7D"
End If

If Not (Trim(Data_date & "") = "") Then
    CreateURL = Left(CreateURL, Len(CreateURL) - 3) & "%2C%22date%22%3A%22" & Data_date & "%22%7D"
End If




End Function

Function Get_value(Json_file As String, Field_name As String, Initial_value As String, Current_amount_values As Integer) As String
Dim tempString As String
Dim Value As String
Dim Field_name_temp As String



Field_name_temp = "my_" & Field_name 'Ensure that field name is not subset of other field name
Value = Initial_value

Pos_field = InStr(Json_file, Field_name_temp & """:")

tempString = Mid(Json_file, Pos_field + Len(Field_name_temp) + 4)

'MsgBox (Mid(tempString, 1, 75))
If Not StrComp(Left(tempString, 1), "}") Then
    Value = Value & "," & ""
Else
    Value = Value & "$" & Replace(Split(tempString, "]")(0), """", "")
End If

If Not InStr(tempString, Field_name_temp & """:") = 0 Then
    Value = Get_value(tempString, Field_name, Value, Current_amount_values + 1)
End If


Get_value = Value




End Function

Sub Set_value(Value As String, Pos_col As Integer, Pos_row As Integer, Pos_row_max As Integer)
Dim i As Integer
Dim HTML As String



HTML = ThisWorkbook.Sheets("ExtractData").Range("A8")

If HTML = "Yes" Or HTML = "" Then
    Value = ParseHTML(Value)
End If

If Value <> "" Then
    If UBound(Split(Value, "$")) = 0 Then
        ThisWorkbook.Sheets("DataReview").Cells(Pos_row, Pos_col).Value = Value
    Else
        If Pos_row < Pos_row_max And ThisWorkbook.Sheets("DataReview").Cells(Pos_row + 1, 1) <> "" Then
            ThisWorkbook.Sheets("DataReview").Cells(Pos_row, Pos_col).Value = Split(Value, "$")(0)
            For i = 1 To UBound(Split(Value, "$"))
                ThisWorkbook.Sheets("DataReview").Cells(Pos_row, Pos_col).Offset(1).EntireRow.Insert
                ThisWorkbook.Sheets("DataReview").Cells(Pos_row + 1, Pos_col).Value = Split(Value, "$")(i)
            Next i
        End If
        ThisWorkbook.Sheets("DataReview").Cells(Pos_row, Pos_col).Value = Split(Value, "$")(0)
        For i = 1 To UBound(Split(Value, "$"))
            ThisWorkbook.Sheets("DataReview").Cells(Pos_row + i, Pos_col).Value = Split(Value, "$")(i)
        Next i
    End If
End If




End Sub

Public Function ParseHTML(ByVal Value As String) As String
Dim htmlContent As New HTMLDocument


htmlContent.body.innerHTML = Value

ParseHTML = htmlContent.body.innerText



End Function

Sub Main_script()
Dim Pos_col As Integer, Pos_row As Integer, Json_file As String, Field_name As String
Dim Value As String
Dim i As Integer
Dim tempValue As String
Dim Pos_row_max As Integer
Dim Enviromment As String
Dim Data_date As String



Pos_col = 2
Pos_row = 2

Call Prepare_sheet

Data_date = Format(ThisWorkbook.Sheets("ExtractData").Range("A5"), "YYYY-MM-DD")
Enviromment = ThisWorkbook.Sheets("ExtractData").Range("A2")

Do While Not IsEmpty(ThisWorkbook.Sheets("DataReview").Cells(Pos_row, 1).Value)
    Json_file = Get_File(Enviromment, Pos_row, Data_date)

    Do While Not IsEmpty(ThisWorkbook.Sheets("DataReview").Cells(1, Pos_col).Value)
        Field_name = ThisWorkbook.Sheets("DataReview").Cells(1, Pos_col).Value
        Value = Mid(Get_value(Json_file, Field_name, "", 0), 2) 'Mid() is used to remove "," from the front of values
        Pos_row_max = Application.Max(Pos_row_max, Pos_row + UBound(Split(Value, "$")))
        Call Set_value(Value, Pos_col, Pos_row, Pos_row_max)
        Pos_col = Pos_col + 1
    Loop
    Pos_col = 2

    Pos_row = Pos_row_max + 1
Loop

ThisWorkbook.Sheets("DataReview").Activate
'Columns.AutoFit
'Rows.AutoFit
Cells.Select
Selection.ColumnWidth = 32
Selection.RowHeight = 15
ThisWorkbook.Sheets("DataReview").Range("A2:HM10000").Select
Selection.Copy
Sheets("Source Data").Select
Sheets("Source Data").Range("A4:HM14000").Select
ActiveSheet.Paste
ThisWorkbook.Sheets("Source Data").Activate




End Sub

Sub Prepare_sheet()
Dim i As Integer
Dim j As Integer



i = 2
j = 2

ThisWorkbook.Sheets("DataReview").Range("A1:HH10000").ClearContents

Do While ThisWorkbook.Sheets("ExtractData").Cells(i, 2).Value <> ""
    ThisWorkbook.Sheets("DataReview").Cells(i, 1).Value = ThisWorkbook.Sheets("ExtractData").Cells(i, 2).Value
    i = i + 1
Loop

Do While ThisWorkbook.Sheets("ExtractData").Cells(j, 3).Value <> ""
    ThisWorkbook.Sheets("DataReview").Cells(1, j).Value = ThisWorkbook.Sheets("ExtractData").Cells(j, 3).Value
    j = j + 1
Loop

ThisWorkbook.Sheets("DataReview").Cells(1, 1).Value = "Product_code"




End Sub

Sub Insert_product_codes(Value As String)


For i = 1 To UBound(Split(Value, ","))
    ThisWorkbook.Sheets("Data").Cells(i, 1).Value = Split(Value, ",")(i)
Next i


End Sub

Module 1 (Containing most of the code):

Module 2 (To transpose data): Here I transpose Data from "Source Data" sheet into "Report" sheet that contains some predefined values in column A

Sub Transpose_Data()
'
' Transpose_Data Macro
'

'
Sheets("Source Data").Select
Rows("4:500").Select
Selection.Copy
Sheets("QRA Report Main").Select
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
Range("B6:MJ6").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlDown
Range("B12:MJ12").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("B17:MJ17").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("B23:MJ23").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("B28:MJ28").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("B36:MJ36").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("B45:MJ45").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("B51:MJ51").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("B54:MJ54").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("B61:MJ61").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown

Columns("B:NZ").Select
Range("B3").Activate
Selection.ColumnWidth = 30
With Selection
    .HorizontalAlignment = xlRight
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
End With

ActiveWorkbook.Save
End Sub

But again as i said, I do not get exactly what I need plus, the processing time is huge.

Please view this resource on `Selection` and why you shouldn't use it in VBA https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba?rq=1 — Badja, Mar 12 '19 at 13:30
@Badja, thank you for the input, but how can I make it work in my code. Just tested it but seems not getting there. Any thught? — lejoyeux3, Mar 12 '19 at 13:38
turn off screen updating, events and calculation while your macro's are running will speed up processing. (don't forget to turn them on again at the end of the routine — Harassed Dad, Mar 12 '19 at 15:31
Use some timers to determine which portion of your code is causing the slowdown. — Ron Rosenfeld, Mar 12 '19 at 20:02
I will appreciate, if by looking at my code, you can rewrite it to fit your suggestion. Thanks — lejoyeux3, Mar 14 '19 at 08:12

score 0 · Answer 1 · answered Mar 15 '19 at 11:02

0

Try this, but note you'll need to fill in the section in the middle. `` Sub Transpose_Data() ' ' Transpose_Data Macro '

'

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Sheets("Source Data").Rows("4:500").Copy Sheets("QRA Report Main").Range("B4")

With Sheets("QRA Report Main")
    .Range("B6:MJ6").Insert Shift:=xlDown
    .Range("B12:MJ12").Resize(2).Insert Shift:=xlDown
    .Range("B17:MJ17").Resize(2).Insert Shift:=xlDown
    .Range("B23:MJ23").Resize(2).Insert Shift:=xlDown

    ' add rest in here

    .Range("B61:MJ61").Resize(2).Insert Shift:=xlDown

    With .Columns("B:NZ")
        .ColumnWidth = 30
        .HorizontalAlignment = xlRight
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
End With

ActiveWorkbook.Save

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

End Sub ``

answered Mar 15 '19 at 11:02

norie

9,609
2
11
18

Thank you Norie, do you think that if I add below statement in module 1, it might it run faster? Application.Calculation = xlCalculationManual Application.ScreenUpdating = False . . . . . . . Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic – lejoyeux3 Mar 18 '19 at 10:00
I tried the above code, below is the error message I got: "Run-time error 1004", you can't past this here because the copy area and the past area aren't the same size. Select just one cell in the past area or an area that's the same size, and try pasting again. The error focues on line: "Sheets("Source Data").Rows("4:500").Copy Sheets("QRA Report Main").Range("B4")" – lejoyeux3 Mar 19 '19 at 08:08
But when I replace "Sheets("Source Data").Rows("4:500").Copy Sheets("QRA Report Main").Range("B4")" by "Sheets("Source Data").Select Rows("4:500").Select Selection.Copy Sheets("QRA Report Main").Select Range("B4").Select Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True " It runs but not faster as expected. – lejoyeux3 Mar 19 '19 at 08:22
Try this. Sheets("Source Data").Rows("4:500").Copy Sheets("QRA Report Main").Range("B4").PasteSpecial xlPasteAll, Transpose:=Tru – norie Mar 20 '19 at 10:54
when I replace with above code, I get following error: "Compile error: expected: end of statement" and that focuses on xlPasteAll. When I also add "Paste:=" so that it becomes "Paste:=xlPasteAll", I still get the same error but this time with focus on "Paste". Any idea? I am still working on it to see if I can find the reason of the error. – lejoyeux3 Mar 25 '19 at 08:24

VBA and Excel optimization of processing time, dealing with several rows

1 Answers1