excel - VBA和Excel优化处理时间，处理多行

Question

你好 StackOverflowers，

我在这里需要一些帮助。

我一直在研究 VBA 代码，但处理数据大约需要 20 到 30 分钟，我需要一些建议来减少处理时间。

我在文档中有 3 张纸。

1- 表 1 称为“ExtractData”。

该表包含 3 列:

A 列:包含“Environment: PROD, Pre-Prod & UAT”，负责根据下拉列表中所述的环境获取数据。
该列还包含解析某些单元格中包含的 html 文本的可能性

B 列:包含产品代码列表

C列:包含我们需要数据的字段/属性的名称。

此外，我们在该工作表中有一个按钮，它应该运行代码以获取数据并将它们显示在名为“源数据”的工作表中

2- 表 2:称为“DataReview”，包含提取的数据，然后我从单元格 A2:MJ500 复制数据内容并将其粘贴到包含一些预定义标题的表 3(源数据)中。
所以我从 A4 粘贴数据

3- 表 3 称为:“源数据”

该工作表将显示基于所述属性获取的所有数据

案例1:我应该做的是根据一些变量过滤数据并将它们转置在单独的表格中:

例1:可以通过VBA按钮，我选择特定的属性，比如基于“产品系列”的过滤器，当你点击运行时，它会复制数据，
然后以特定方式将它们转置在以产品系列名称命名的单独工作表中

但是，我尝试了不同的方法，但我没有得到我想要的。

下面找到我正在使用的代码，请仔细阅读并帮助我改进它。

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

模块 1(包含大部分代码):

模块 2(转置数据):在这里，我将“源数据”表中的数据转置为“报告”表，其中包含 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

但正如我所说，我没有得到我需要的东西，而且处理时间很长。

Answer 1

试试这个，但请注意，您需要填写中间部分。
``
子转置_数据()
'
' 转置数据宏
'

'

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

结束子
``