VBA и Excel оптимизация времени обработки, работающая с несколькими строками - PullRequest
Новая
       0

VBA и Excel оптимизация времени обработки, работающая с несколькими строками

2 голосов
/ 12 марта 2019

Hello StackOverflowers,

Мне нужна помощь сома.

Я работал над кодом VBA, но обработка данных занимает около 20-30 минут, и мне нужно несколько советов, чтобы сократить время обработки.

У меня есть 3 листа в документе.

1 - Лист 1 называется «ExtractData».

Этот лист содержит 3 столбца:

Столбец A: содержит «Среда: PROD, Pre-Prod & UAT», отвечающая за выборку данных на основе среды, указанной в раскрывающемся списке. Этот столбец также содержит возможность разбора HTML-текста, содержащегося в некоторых ячейках

Колонка B: содержит список кодов продукции

Столбец C: содержит названия полей / атрибутов, для которых нам нужны данные.

Кроме того, у нас есть кнопка на этом листе, которая должна запустить код для извлечения данных и отобразить их на листе под названием «Исходные данные»

2 - Лист 2: Вызывается «DataReview», содержащий извлеченные данные, затем я копирую содержимое данных из ячейки A2: MJ500 и вставляю его в лист 3 (Исходные данные), который содержит некоторые предопределенные заголовки. Поэтому я вставляю данные из формата А4

3- Лист 3 называется: «Исходные данные»

На этом листе будут отображаться все данные, извлеченные на основе указанного атрибута

СЛУЧАЙ 1: Что я должен сделать, это отфильтровать данные на основе некоторой переменной и перенести их на отдельный лист:

Пример 1. Может, с помощью кнопки VBA, я выбираю определенный атрибут, например, фильтр на основе «Семейства продуктов», когда вы нажимаете кнопку «Выполнить», он копирует данные, затем перенести их особым образом на отдельном листе, названном по фамилии Product

НО, я пытался разными способами и не получаю то, что хотел.

Ниже найдите код, который я использую, пройдите его и помогите мне сделать его лучше. 

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

Но опять же, как я уже сказал, я не получаю именно то, что мне нужно, плюс, время обработки огромно.

1 Ответ

0 голосов
/ 15 марта 2019

Попробуйте, но обратите внимание, что вам нужно заполнить раздел в середине. `` 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 ``

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...