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

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.

Answer 1

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
``