Эффективный способ сопоставления / объединения нескольких диапазонов или массивов по дате

Question

Я не смогу сделать это вычисление эффективно с Excel (VBA):

Ввод

Вывод

Делать это с таблицами невероятно медленно, когда у вас есть несколько строк и столбцы работают отлично , но не практично, когда вы увеличиваете количество рядов и строк.

Что я делаю, это обновляет выходную таблицу с помощью VBA, шаги:

1. Удаление данных из выходной таблицы Listobject
2. Изменение размера списка объектов Listobject с указанием числа дат между (min max Dates1, Dates, 2)
3. Создание дат и выгрузка их в столбец Выходные даты таблиц объектов.

I получить соответствие с этой формулой массива формул в каждой строке Result в выходной таблице listobject:

=SUM(IF((DAY(T_1[Date])=DAY([@Date]))*(MONTH(T_1[Date])=MONTH([@Date]))*(YEAR(T_1[Date])=AÑO([@Date]));T_1[Result1]))

Число рядов - dinami c, а строки будут динамическими c, у меня есть до 30 столбцы и 5000 строк. Не могли бы вы привести какой-нибудь пример или подход для более эффективного достижения этой цели?

Вот таблица с указанием скорости выполнения фрагментов участников. Проверено с целыми данными. 3161 строк x 40 столбцов (20 соответствующих столбцов результатов):

Таблица времени выполнения

Answer 1

Следующее не перечисляет даты по порядку, но собирает данные для каждой входной даты. Она аналогична сводной таблице.

Сравните скорость выполнения с другим кодом.

Sub MergeData()
    Dim strU As String
    Dim myWs As Worksheet, Ws As Worksheet
    Dim vTable() As Variant
    Dim vFid1(), vFid2()
    Dim k As Integer, n As Integer, c As Integer
    Dim sWsName As String, s As String
    Dim strSQL As String

    Set myWs = Sheets(1) '<~~ Your data Sheet
    Set Ws = Sheets(2)   '<~~ Result Sheet

    sWsName = myWs.Name & "$"
    With myWs
       c = .Cells(1, Columns.Count).End(xlToLeft).Column
       For i = 1 To c Step 2
           n = n + 1
           ReDim Preserve vTable(1 To n)
           ReDim Preserve vFid1(1 To n)
           ReDim Preserve vFid2(1 To n)
           vTable(n) = sWsName & .Cells(1, i).Resize(65536, 2).Address(0, 0)
           vFid1(n) = "[" & .Cells(1, i) & "]"
           vFid2(n) = "[" & .Cells(1, i + 1) & "]"
       Next i
    End With

    For k = 1 To n - 1
        s = Replace(vFid2(k), "[", "")
        s = Replace(s, "]", "")
        strU = strU & "SELECT " & vFid1(k) & " as Dates ," & vFid2(k) & " as Result , '" & s & "' as myPivot " & "  FROM [" & vTable(k) & "] where not isnull(" & vFid1(k) & ") union All "
    Next k
    s = Replace(vFid2(n), "[", "")
    s = Replace(s, "]", "")
    strU = strU & "SELECT " & vFid1(n) & "  as Dates," & vFid2(n) & "  as Result, '" & s & "' as myPivot " & "  FROM [" & vTable(n) & "]  where not isnull(" & vFid1(n) & ") "


    strSQL = "TRANSFORM MAX(Result) "
    strSQL = strSQL & "SELECT Dates FROM "
    strSQL = strSQL & "(" & strU & ")  "
    strSQL = strSQL & "GROUP BY Dates "
    strSQL = strSQL & "ORDER BY Dates "
    strSQL = strSQL & "PIVOT myPivot "

    exeSQL Ws, strSQL
    Ws.Range("a1").CurrentRegion.SpecialCells(xlCellTypeBlanks).Value = 0
End Sub

Sub exeSQL(Ws As Worksheet, strSQL As String)

    Dim Rs As Object
    Dim strConn As String
    Dim i As Integer

    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & ThisWorkbook.FullName & ";" & _
            "Extended Properties=Excel 12.0;"

    Set Rs = CreateObject("ADODB.Recordset")
    Rs.Open strSQL, strConn

    If Not Rs.EOF Then
         With Ws
            .Range("a1").CurrentRegion.ClearContents
            For i = 0 To Rs.Fields.Count - 1
               .Cells(1, i + 1).Value = Rs.Fields(i).Name
            Next
            .Range("a" & 2).CopyFromRecordset Rs
        End With
    End If
    Rs.Close
    Set Rs = Nothing
End Sub

Изображение данных

можно расширить на 30 серий. Это всего 5 серий.

Результат изображения

Answer 2

Я собрал что-то вместе, используя наборы записей ADODB, чтобы я мог использовать .Filter и .Find. Этот код выводит уникальные даты, а затем результат в эту дату для каждого набора результатов.

Const AD_DATE = 7
Const AD_VARIANT = 12
Const AD_BIGINT = 20
Const AD_VARCHAR = 200
Const AD_FILTERNONE = 0

Sub sResultData()
    On Error GoTo E_Handle
    Dim aResultSet() As String
    Dim lngMaxCol As Long
    Dim lngMaxRow As Long
    Dim lngLoopRow As Long
    Dim lngLoopCol As Long
    Dim rsMaster As Object
    Dim rsDate As Object
    Set rsMaster = CreateObject("ADODB.Recordset")
    Set rsDate = CreateObject("ADODB.Recordset")
    lngMaxRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
    lngMaxCol = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column
    With rsMaster.Fields
        .Append "ResultDate", AD_DATE
        .Append "ResultSet", AD_VARCHAR, 50
        .Append "ResultData", AD_BIGINT
    End With
    With rsDate.Fields
        .Append "ResultDate", AD_DATE
    End With
    rsMaster.Open
    rsDate.Open
    ReDim aResultSet(1 To lngMaxCol / 2)
    For lngLoopCol = 2 To lngMaxCol Step 2
        aResultSet(lngLoopCol / 2) = ActiveSheet.Cells(1, lngLoopCol)
    Next lngLoopCol

    For lngLoopRow = 2 To lngMaxRow
        For lngLoopCol = 2 To lngMaxCol Step 2
            With rsMaster
                .AddNew
                !ResultDate = ActiveSheet.Cells(lngLoopRow, lngLoopCol - 1)
                !ResultSet = ActiveSheet.Cells(1, lngLoopCol)
                !ResultData = ActiveSheet.Cells(lngLoopRow, lngLoopCol)
                .Update
            End With
            If (rsDate.BOF And rsDate.EOF) Then '   dealing with first record, so cannot do .Find
                rsDate.AddNew
                rsDate!ResultDate = ActiveSheet.Cells(lngLoopRow, lngLoopCol - 1)
                rsDate.Update
            Else
                rsDate.MoveFirst
                rsDate.Find "ResultDate=" & Format(ActiveSheet.Cells(lngLoopRow, lngLoopCol - 1), "dd/mmm/yyyy")
                If (rsDate.EOF) Or (rsDate.EOF) Then
                    rsDate.AddNew
                    rsDate!ResultDate = ActiveSheet.Cells(lngLoopRow, lngLoopCol - 1)
                    rsDate.Update
                End If
            End If
        Next lngLoopCol
    Next lngLoopRow

    rsDate.Sort = "ResultDate ASC"
    rsDate.MoveFirst
    rsMaster.Sort = "ResultSet ASC, ResultDate ASC"

    For lngLoopCol = 1 To UBound(aResultSet)
        lngLoopRow = lngMaxRow + 5
        ActiveSheet.Cells(lngLoopRow - 1, lngLoopCol + 1) = aResultSet(lngLoopCol)
        rsMaster.Filter = AD_FILTERNONE
        rsMaster.Filter = "ResultSet='" & aResultSet(lngLoopCol) & "'"
        rsDate.MoveFirst
        Do
            ActiveSheet.Cells(lngLoopRow, 1) = rsDate!ResultDate
            rsMaster.MoveFirst
            rsMaster.Find "ResultDate=#" & Format(rsDate!ResultDate, "dd-mmm-yy") & "#"
            If Not rsMaster.EOF Then
                ActiveSheet.Cells(lngLoopRow, lngLoopCol + 1) = rsMaster!ResultData
            End If
            lngLoopRow = lngLoopRow + 1
            rsDate.MoveNext
        Loop Until rsDate.EOF
    Next lngLoopCol

sExit:
    On Error Resume Next
    rsDate.Close
    rsMaster.Close
    Set rsDate = Nothing
    Set rsMaster = Nothing
    Exit Sub
E_Handle:
    MsgBox Err.Description & vbCrLf & vbCrLf & "sResultData", vbOKOnly + vbCritical, "Error: " & Err.Number
    Resume sExit
End Sub

С уважением,

Answer 3

Приведенный ниже код позволяет указать столбцы, из которых нужно собирать данные, и вывести результат на специальный лист, который необходимо будет вставить для этой цели. Я назвал это «Выход», но вы можете выбрать имя, которое подходит вам лучше. Ваши исходные данные не будут затронуты.

Sub MergeDataByDate()
    ' 006

    ' define the origin of your data
    Const FirstDataRow As Long = 2              ' applicable to both data sets
    ' set the columns to what they are on your sheet (A = 1, B = 2 etc)
    Const C1 As Long = 2                        ' Date 1 column
    Const Cr1 As Long = 3                       ' Result 1 column
    Const C2 As Long = 8                        ' Date 2 column
    Const Cr2 As Long = 11                      ' Result 2 column

    Dim WsOut As Worksheet                      ' worksheet for output
    Dim ArrIn As Variant                        ' for input
    Dim Arr() As Variant                        ' for output
    Dim Dat As Date                             ' date counter
    Dim Rng As Range
    Dim i As Long                               ' Arr index
    Dim R As Long                               ' row counter

    Set WsOut = Worksheets("Output")            ' the output sheet must exist: rename to suit
    With Worksheets("Input")                    ' use your tab's name
        Set Rng = .Range(.Cells(FirstDataRow, 1), _
                         .Cells(.Rows.Count, C1).End(xlUp) _
                         .Offset(0, Cr2 - C1))
        ArrIn = Rng.Value
        ReDim Arr(1 To 3, (2 * UBound(ArrIn)))

        For R = 1 To UBound(ArrIn)
            Arr(1, i) = ArrIn(R, C1)
            Arr(2, i) = ArrIn(R, Cr1)
            Arr(1, i + 1) = ArrIn(R, C2)
            Arr(3, i + 1) = ArrIn(R, Cr2)
            i = i + 2
        Next R
    End With

    Application.ScreenUpdating = False
    With WsOut
        Set Rng = .Cells(2, 1).Resize(UBound(Arr, 2), UBound(Arr))
        Rng.Value = Application.Transpose(Arr)

        With .Sort
            With .SortFields
                .Clear
                .Add Key:=Rng.Cells(1), _
                     SortOn:=xlSortOnValues, _
                     Order:=xlAscending, _
                     DataOption:=xlSortTextAsNumbers
            End With
            .SetRange Rng
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With

    Arr = Rng.Value
    For R = (UBound(Arr) - 1) To 1 Step -1
        If Arr(R + 1, 1) = Arr(R, 1) Then
            Arr(R, 2) = Arr(R, 2) + Arr(R + 1, 2)
            Arr(R, 3) = Arr(R, 3) + Arr(R + 1, 3)
            For i = 1 To 3
                Arr(R + 1, i) = vbNullString
            Next i
        Else
            Arr(R, 2) = Val(Arr(R, 2)) + 0
            Arr(R, 3) = Val(Arr(R, 3)) + 0
        End If
    Next R
    Rng.Value = Arr

    With WsOut                          ' sort blanks to the bottom
        With .Sort
            With .SortFields
                .Clear
                .Add Key:=Rng.Cells(1), _
                     SortOn:=xlSortOnValues, _
                     Order:=xlAscending, _
                     DataOption:=xlSortTextAsNumbers
            End With
            .SetRange Rng
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        R = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dat = CLng(Cells(R, 1).Value)
        For R = R To 3 Step -1
            Dat = Dat - 1
            Do Until .Cells(R - 1, 1).Value = Dat
                .Rows(R).Insert
                .Cells(R, 1).Value = Dat
                .Cells(R, 2).Value = 0
                .Cells(R, 3).Value = 0
                Dat = Dat - 1
            Loop
        Next R
    End With
    Application.ScreenUpdating = True
End Sub

Код сначала объединяет существующие данные в один список, а затем сортирует список по дате. Затем он объединяет данные за одни и те же дни в одну строку, удаляя ненужные строки и сортируя их в конец списка, где они исчезают.

На последнем шаге оставшиеся данные проверяются на даты, а пропущенные даты вставляются между последней первой датой в списке и последней. Например, если вы особенно относитесь к этим датам, вы хотите, чтобы они были первым и последним днем ​​месяца, то наиболее эффективно добавить эти два дня с нулевыми результатами в любом месте исходных данных. Если результаты для этих дат существуют, нулевые значения будут отброшены. Если они этого не сделают, и любые промежуточные дни будут добавлены к выводу.

Answer 4

Проверьте следующий код, пожалуйста. Он будет иметь дело с тем количеством (пар) столбцов, которое у вас будет. Он определяет минимальную, соответственно, максимальную использованную дату и выполняет итерации между определенным интервалом, собирая данные в массиве arrFin. Вы также можете использовать любой интервал дат. Интервал будет определен автоматически. Мой код сбрасывает значения на один столбец после существующего диапазона. Это сделано только для проверки . Я должен проверить это таким образом ... Вы можете бросить их туда, где вам нужно. Таким образом, если вы намереваетесь запустить код во второй раз, , вы должны удалить ранее возвращенные значения .

Sub testMatchReArrange()
  Dim sh As Worksheet, arrD As Variant, DateRng As Range, lastCol As Long, lastRow As Long
  Dim i As Long, dateStart As Date, dateFinish As Date, dDiff As Long, arrFin As Variant
  Dim boolFound As Boolean, checkDate As Date, j As Long, k As Long, f As Long

   Set sh = ActiveSheet 'use here your sheet
   lastRow = sh.Range("A" & Rows.count).End(xlUp).Row
   lastCol = sh.Cells(1, Columns.count).End(xlToLeft).Column
   arrD = sh.Range(sh.Cells(2, 1), Cells(lastRow, lastCol)).value 'array to be processed
   'create the specific range keeping only Date, in order to determine the correct date interval. Especially the  minimum date...
   For i = 1 To lastCol Step 2
        If DateRng Is Nothing Then
            Set DateRng = sh.Range(sh.Cells(2, i), sh.Cells(lastRow, i))
        Else
             Set DateRng = Union(DateRng, sh.Range(sh.Cells(2, i), sh.Cells(lastRow, i)))
        End If
   Next i
   dateStart = WorksheetFunction.Min(DateRng)  'starting date
   dateFinish = WorksheetFunction.Max(DateRng) 'finishing date
   dDiff = dateFinish - dateStart  'the date interval to be processed
   'Properly dimension the array to collect the processing result:
   ReDim arrFin(1 To dDiff + 2, 1 To lastCol / 2 + 1): f = 1
   'Load the head of columns:
   arrFin(1, 1) = "Dates"
   For i = 2 To lastCol / 2 + 1
        arrFin(1, i) = "result" & i - 1
   Next i
   f = 2 're-initializing the row of for real processed data
   checkDate = dateStart 'initialize the date to be used for processing
   For i = 1 To dDiff + 1  'for each date in the processed date interval
        For j = 1 To UBound(arrD, 1) 'for each row in the processed array
            For k = 1 To UBound(arrD, 2) Step 2 'for each column in the processed array (but looking only in add columns)
                If CDate(arrD(j, k)) = checkDate Then
                    arrFin(f, 1) = checkDate: arrFin(f, (k + 1) / 2 + 1) = arrD(j, k + 1)
                    boolFound = True 'confirming that at least a match exist
                End If
            Next k
        Next j
        If Not boolFound Then arrFin(f, 1) = checkDate' Record the date in case of no any match
        boolFound = False: f = f + 1
        checkDate = checkDate + 1
   Next i
    'you can use here any other location (sheet, range) to drop the resulted array:
   sh.Cells(1, lastCol + 2).Resize(UBound(arrFin, 1), UBound(arrFin, 2)).value = arrFin
End Sub

В случае большого диапазона требуется некоторое время, но работая только в памяти (используя массивы) это максимально возможная скорость для такой задачи.

Answer 5

Сначала я сделал предположение, что у вас есть даты и результаты в соседних столбцах в виде Dates N | Results N, изображение ниже.

Во-вторых, я написал следующий код, который должен решить вашу проблему. Примечание: это не является полностью масштабируемым, но вы можете использовать это сейчас, чтобы прогрессировать дальше и изменять ваши потребности. Кроме того, прошу прощения за мою плохую математику, чтобы вычислить переменную out_col_num.

Option Explicit

Sub Merge_Dates()

    'variables to set up dates
    Dim lYear As Long: lYear = 2020
    Dim lMonth As Long: lMonth = 3
    Dim lDay As Long


    'arrays
    Dim arr_in() As Variant
    Dim arr_out() As Variant
    Dim x_in As Long, y_in As Long
    Dim x_out As Long, y_out As Long
    Dim out_col_num As Long, n As Long: n = 1


    arr_in = ActiveSheet.UsedRange.Value

    'we need to define the bounds for the output array
    'this will contain all dates for March (in this example)
    'also hold the results in the columns - this is a function on lbound(2)
    ReDim arr_out(1 To 32, 1 To (UBound(arr_in, 2) - 1))

    'header for out array
    arr_out(1, 1) = "Dates"

    'load dates
    For lDay = 1 To 31
        arr_out(lDay + 1, 1) = CDate(Format(DateSerial(lYear, lMonth, lDay), "DD/MM/YYYY"))
    Next lDay

    'set column headers
    For x_out = LBound(arr_out, 2) + 1 To UBound(arr_out, 2)
        arr_out(1, x_out) = "Results" & (x_out - 1)
    Next x_out

    'now loop through in array and map to out array
    'you can do this multiple ways, below is just one
    'loop x dim in array
    For x_in = LBound(arr_in, 2) To UBound(arr_in, 2) Step 2
        'loop y dim in array
        For y_in = LBound(arr_in, 1) + 1 To UBound(arr_in, 1)
            'loop y dim out array to store result
            For y_out = LBound(arr_out, 1) + 1 To UBound(arr_out, 1)
                If arr_out(y_out, 1) = arr_in(y_in, x_in) Then
                    'out column is a function of in column
                    '-n + 3n
                    out_col_num = (-1 * x_in) + (3 * n)
                    arr_out(y_out, out_col_num) = arr_in(y_in, x_in + 1)
                    Exit For
                End If
            Next y_out
        Next y_in

        'increment n
        n = n + 1

    Next x_in

    'output
    ActiveSheet.Range("A10").Resize(UBound(arr_out, 1), UBound(arr_out, 2)).Value = arr_out

End Sub

Итак, учитывая пример, предполагая, что ваши даты охватывают только март 2020 года (что-то, что вам придется изменить, чтобы сделать его более масштабируемым):

выдаст вывод, как показано ниже:

Answer 6

Мне понадобилось время, но вот мой код:

Sub SubOutput()

    'Declarations.
    Dim WksInput As Worksheet
    Dim WksOutput As Worksheet
    Dim RngInputFirstCell As Range
    Dim RngOutputFirstCell As Range
    Dim BytOffset As Byte
    Dim RngRange01 As Range
    Dim RngTarget As Range
    Dim BytWholeCalendar As Byte
    Dim DatFirstDate As Date
    Dim DatLastDate As Date
    Dim IntCounter01 As Integer

    'Setting variables.
    Set WksInput = Sheets("Input")                'put here the name of the worksheet with input data
    Set WksOutput = Sheets("Output")               'put here the name of the worksheet with the output data
    Set RngInputFirstCell = WksInput.Range("A1")    'put here the top left cell of the input data (the one with value Dates1)
    Set RngOutputFirstCell = WksOutput.Range("A1")  'put here the top left cell of the output data (the one with value Dates)

    'Asking what days are to be reported.
    BytWholeCalendar = MsgBox("Do you need the output to report data for every day?", vbYesNoCancel, "Report every day?")

    'In case of no answer, the subroutine is terminated.
    If BytWholeCalendar <> 6 And BytWholeCalendar <> 7 Then
        Exit Sub
    End If

    'Typing "Dates" in RngOutputFirstCell.
    RngOutputFirstCell = "Dates"

    'Covering the entire input.
    Do Until RngInputFirstCell.Offset(0, BytOffset * 2) = ""
        'Setting first part of the range to be copied (dates).
        Set RngRange01 = WksInput.Range(RngInputFirstCell.Offset(1, BytOffset * 2), WksInput.Cells(WksInput.Rows.Count, RngInputFirstCell.column + BytOffset * 2).End(xlUp))

        'Setting the range where to paste the dates.
        Set RngTarget = WksOutput.Cells(WksOutput.Rows.Count, RngOutputFirstCell.column).End(xlUp).Offset(1, 0)
        Set RngTarget = RngTarget.Resize(RngRange01.Rows.Count)
        'Pasting the dates.
        RngTarget.Value = RngRange01.Value

        'Copying the result name.
        RngOutputFirstCell.Offset(0, BytOffset + 1).Value = RngInputFirstCell.Offset(0, BytOffset * 2 + 1).Value

        'Setting BytOffset to cover the next rows of data.
        BytOffset = BytOffset + 1
    Loop

    'Editing the dates according to BytWholeCalendar.
    Select Case BytWholeCalendar
        Case Is = 6
            'Setting variables.
            DatFirstDate = Excel.WorksheetFunction.Min(WksOutput.Range(RngOutputFirstCell.Offset(1, 0), RngOutputFirstCell.End(xlDown)))
            DatLastDate = Excel.WorksheetFunction.Max(WksOutput.Range(RngOutputFirstCell.Offset(1, 0), RngOutputFirstCell.End(xlDown)))
            IntCounter01 = 1

            'Clearing dates.
            WksOutput.Range(RngOutputFirstCell.Offset(1, 0), RngOutputFirstCell.End(xlDown)).ClearContents

            'Filling dates.
            For DatFirstDate = DatFirstDate To DatLastDate
                RngOutputFirstCell.Offset(IntCounter01, 0).Value = DatFirstDate
                IntCounter01 = IntCounter01 + 1
            Next DatFirstDate


        Case Is = 7
            'Sorting output dates.
            With WksOutput.Sort
                .SortFields.Clear
                .SortFields.Add Key:=RngOutputFirstCell, _
                                SortOn:=xlSortOnValues, _
                                Order:=xlAscending, _
                                DataOption:=xlSortTextAsNumbers
                .SetRange Range(RngOutputFirstCell, RngOutputFirstCell.End(xlDown))
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With

            'Marking unique dates.
            Set RngTarget = WksOutput.Range(RngOutputFirstCell.Offset(1, 1), RngOutputFirstCell.End(xlDown).Offset(0, 1))
            RngTarget.FormulaR1C1 = "=IF(RC[-1]=R[1]C[-1],"""",""X"")"
            RngTarget.Value = RngTarget.Value

            'Sorting output dates by unique values.
            With WksOutput.Sort
                .SortFields.Clear
                .SortFields.Add Key:=RngOutputFirstCell.Offset(0, 1), _
                                SortOn:=xlSortOnValues, _
                                Order:=xlAscending, _
                                DataOption:=xlSortTextAsNumbers
                .SetRange Range(RngOutputFirstCell.Offset, RngOutputFirstCell.End(xlDown).Offset(0, 1))
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With

            'Clearing double dates.
            With WksOutput.Range(RngOutputFirstCell.End(xlDown), RngOutputFirstCell.Offset(0, 1).End(xlDown).Offset(1, 0))
                .ClearContents
                .ClearFormats
            End With

    End Select

    'Setting RngTarget to cover the results' part of the output.
    Set RngTarget = WksOutput.Range(RngOutputFirstCell.Offset(1, 1), RngOutputFirstCell.End(xlDown).Offset(0, 1))
    Set RngTarget = RngTarget.Resize(, BytOffset)

RngTarget.FormulaR1C1 = "=VLOOKUP(RC" & RngOutputFirstCell.column & ",OFFSET(INDIRECT(""" & WksInput.Name & "!R" & RngInputFirstCell.Row + 1 & "C""" & " & MATCH(R" & RngOutputFirstCell.Row & "C," & WksInput.Name & "!" & WksInput.Range(RngInputFirstCell, RngInputFirstCell.End(xlToRight)).Address(, , xlR1C1) & ",0) + " & RngInputFirstCell.column - 1 & ",FALSE),0,-1,5000,2),2,FALSE)"
    'Typing in RngTarget the formula.
    'RngTarget.FormulaR1C1 = "=IFERROR(VLOOKUP(RC" & RngOutputFirstCell.column & ",OFFSET(INDIRECT(""" & WksInput.Name & "!R" & RngInputFirstCell.Row + 1 & "C""" & " & MATCH(R" & RngOutputFirstCell.Row & "C," & WksInput.Name & "!" & WksInput.Range(RngInputFirstCell, RngInputFirstCell.End(xlToRight)).Address(, , xlR1C1) & ",0) + " & RngInputFirstCell.column - 1 & ",FALSE),0,-1,5000,2),2,FALSE),0)"

    'Transforming formulas into values.
    'RngTarget.Value = RngTarget.Value

    'Setting RngTarget to select the output data.
    Set RngTarget = RngTarget.Offset(0, -1).Resize(, RngTarget.Columns.Count + 1)

    'Formatting.
    With RngTarget
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlMedium
        End With
    End With

    'Setting RngTarget to select the output labels.
    Set RngTarget = RngTarget.Offset(-1, 0).Resize(1)

    'Formatting.
    With RngTarget
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlMedium
        End With
    End With
    RngTarget.EntireColumn.AutoFit

    Debug.Print "REPORT"; " | "
    Debug.Print "WksInput.Parent.Name = WksOutput.Parent.Name ? "; WksInput.Parent.Name = WksInput.Parent.Name; " | "
    Debug.Print "WksInput.Name ? "; WksInput.Name; " | "
    Debug.Print "RngInputFirstCell.Address ? "; RngInputFirstCell.Address; " | "
    Debug.Print "RngInputFirstCell.Value ? "; RngInputFirstCell.Value; " | "
    Debug.Print "RngInputFirstCell.Formula ? "; RngInputFirstCell.Formula; " | "
    Debug.Print "RngInputFirstCell.Offset(1,0).Address ? "; RngInputFirstCell.Offset(1, 0).Address; " | "
    Debug.Print "RngInputFirstCell.Offset(1,0).Value ? "; RngInputFirstCell.Offset(1, 0).Value; " | "
    Debug.Print "RngInputFirstCell.Offset(1,0).Formula ? "; RngInputFirstCell.Offset(1, 0).Formula; " | "
    Debug.Print "RngInputFirstCell.Offset(0,1).Address ? "; RngInputFirstCell.Offset(0, 1).Address; " | "
    Debug.Print "RngInputFirstCell.Offset(0,1).Value ? "; RngInputFirstCell.Offset(0, 1).Value; " | "
    Debug.Print "RngInputFirstCell.Offset(0,1).Formula ? "; RngInputFirstCell.Offset(0, 1).Formula; " | "
    Debug.Print "RngInputFirstCell.Offset(1,1).Address ? "; RngInputFirstCell.Offset(1, 1).Address; " | "
    Debug.Print "RngInputFirstCell.Offset(1,1).Value ? "; RngInputFirstCell.Offset(1, 1).Value; " | "
    Debug.Print "RngInputFirstCell.Offset(1,1).Formula ? "; RngInputFirstCell.Offset(1, 1).Formula; " | "
    Debug.Print "RngInputFirstCell.Offset(91,0).Address ? "; RngInputFirstCell.Offset(91, 0).Address; " | "
    Debug.Print "RngInputFirstCell.Offset(91,0).Value ? "; RngInputFirstCell.Offset(91, 0).Value; " | "
    Debug.Print "RngInputFirstCell.Offset(91,0).Formula ? "; RngInputFirstCell.Offset(91, 0).Formula; " | "
    Debug.Print "RngInputFirstCell.Offset(91,1).Address ? "; RngInputFirstCell.Offset(91, 1).Address; " | "
    Debug.Print "RngInputFirstCell.Offset(91,1).Value ? "; RngInputFirstCell.Offset(91, 1).Value; " | "
    Debug.Print "RngInputFirstCell.Offset(91,1).Formula ? "; RngInputFirstCell.Offset(91, 1).Formula; " | "
    Debug.Print "WksOutput.Name ? "; WksOutput.Name; " | "
    Debug.Print "RngOutputFirstCell.Address ? "; RngOutputFirstCell.Address; " | "
    Debug.Print "RngOutputFirstCell.Value ? "; RngOutputFirstCell.Value; " | "
    Debug.Print "RngOutputFirstCell.Formula ? "; RngOutputFirstCell.Formula; " | "
    Debug.Print "RngOutputFirstCell.Offset(1,0).Address ? "; RngOutputFirstCell.Offset(1, 0).Address; " | "
    Debug.Print "RngOutputFirstCell.Offset(1,0).Value ? "; RngOutputFirstCell.Offset(1, 0).Value; " | "
    Debug.Print "RngOutputFirstCell.Offset(1,0).Formula ? "; RngOutputFirstCell.Offset(1, 0).Formula; " | "
    Debug.Print "RngOutputFirstCell.Offset(0,1).Address ? "; RngOutputFirstCell.Offset(0, 1).Address; " | "
    Debug.Print "RngOutputFirstCell.Offset(0,1).Value ? "; RngOutputFirstCell.Offset(0, 1).Value; " | "
    Debug.Print "RngOutputFirstCell.Offset(0,1).Formula ? "; RngOutputFirstCell.Offset(0, 1).Formula; " | "
    Debug.Print "RngOutputFirstCell.Offset(1,1).Address ? "; RngOutputFirstCell.Offset(1, 1).Address; " | "
    Debug.Print "RngOutputFirstCell.Offset(1,1).Value ? "; RngOutputFirstCell.Offset(1, 1).Value; " | "
    Debug.Print "RngOutputFirstCell.Offset(1,1).Formula ? "; RngOutputFirstCell.Offset(1, 1).Formula; " | "
    Debug.Print "RngOutputFirstCell.Offset(91,0).Address ? "; RngOutputFirstCell.Offset(91, 0).Address; " | "
    Debug.Print "RngOutputFirstCell.Offset(91,0).Value ? "; RngOutputFirstCell.Offset(91, 0).Value; " | "
    Debug.Print "RngOutputFirstCell.Offset(91,0).Formula ? "; RngOutputFirstCell.Offset(91, 0).Formula; " | "
    Debug.Print "RngOutputFirstCell.Offset(91,1).Address ? "; RngOutputFirstCell.Offset(91, 1).Address; " | "
    Debug.Print "RngOutputFirstCell.Offset(91,1).Value ? "; RngOutputFirstCell.Offset(91, 1).Value; " | "
    Debug.Print "RngOutputFirstCell.Offset(91,1).Formula ? "; RngOutputFirstCell.Offset(91, 1).Formula; " | "

End Sub

Бит, да. Тем не менее это должно работать. Просто убедитесь, что правильно установили эти 4 переменные в начале (WksInput, WksOutput, RngInputFirstCell, RngOutputFirstCell). Заметки помогут вам. Код записывается в предыдущий вывод, но не очищает его (тем не менее, его можно изменить соответствующим образом). Также применяется часть формата, который вы использовали в своих примерах (с более подробной информацией можно полностью редактировать формат).

Если вам нужны какие-либо пояснения, просто скажите, пожалуйста.