Сопоставить 2D-массивы и выходные значения другого массива

Question

Я не могу получить рабочее состояние для сопоставления 2D-массивов. Я попробовал другой подход, и он ближе к решению, но все равно не дает результата.

Вот что я хочу сделать:

В листе 1 у меня есть разные даты, которые проходят через столбцы, и размер не определен. Ниже этих дат находятся значения:

На листе 2 у меня есть меньшее подмножество дат (которое должно существовать на листе 1):

С помощью кода я хочу сопоставить даты в sheet1 и sheet2, и только если для параметра true установлено значение true, я хочу записать соответствующие значения из sheet1 в sheet2. Это результат:

Я хочу использовать массивы для дат в sheet1 и sheet2 и, если они совпадают, записать массив значений. Но массивы дат оказываются пустыми, поэтому условие совпадения не работает. Я также не получаю сообщение об ошибке:

Sub test()

    Dim arrAmounts() As Variant
    Dim arrDates_w2() As Variant
    Dim arrDates_w1() As Variant
    Dim Lastcol_w2 As Integer
    Dim Lastcol_w1 As Integer
    Dim LastRow As Integer
    Dim i As Integer
    Dim w As Integer
    Dim d As Integer
    Dim f As Integer
    Dim g As Integer
    Dim w1 As Worksheet
    Dim w2 As Worksheet

    Set w1 = Sheets("Sheet1")
    Set w2 = Sheets("Sheet2")
    LastRow = 17 'last row on both sheets
    f = 1
    g = 1

With w2
    Lastcol_w2 = .Cells(3, Columns.Count).End(xlToLeft).Column

    'array of dates in w2
    ReDim arrDates_w2(1, Lastcol_w2)

End With



With w1
  Lastcol_w1 = .Cells(3, Columns.Count).End(xlToLeft).Column  

'Assign arrays:
    ReDim arrAmounts(LastRow, Lastcol_w1)
    ReDim arrDates_w1(1, Lastcol_w1)

    For i = 1 To LastRow
        For d = 1 To UBound(arrDates_w1, 2)
            arrAmounts(i, d) = .Cells(3 + i, 2 + d)
        Next
    Next


'Match the dates in worksheets 1 and 2
    For i = 1 To LastRow
        For w = 1 To UBound(arrDates_w2, 2)
           For d = 1 To UBound(arrDates_w1, 2)
              If arrDates_w2(1, w) = arrDates_w1(1, d) Then
                w2.Cells(i + 3, 2 + w) = arrAmounts(i, f + 3)
              End If
           Next
        Next
    Next

End With


End Sub

Буду признателен за предложения.

Answer 1

Что вы ожидаете от ReDim arrDates_w2(1, Lastcol_w2)?В настоящее время он только изменяет количество элементов, которые могут храниться в массиве ... Вам нужно присвоить ему Range: arrDates_w2 = w2.Range("C3:K3").Value например.Это создаст многомерный массив.

Затем вы можете зациклить элементы.Вот пример кода, иллюстрирующий принцип

Sub GetArrayInfo()
    Dim a As Variant, i As Long, j As Long
    Dim w2 As Worksheet

   Set w2 = Sheets("Sheet2")
   a = ws.Range("C3:K3").Value2
   Debug.Print UBound(a, 1), UBound(a, 2)
   For j = 1 To UBound(a, 2)
    For i = 1 To UBound(a, 1)
        Debug.Print a(i, j)
    Next
   Next
End Sub

Answer 2

Попробуйте

Sub test()
    Dim Ws As Worksheet, Ws2 As Worksheet
    Dim c As Integer, j As Integer, p As Integer
    Dim i As Long, r As Long
    Dim arr1() As Variant, arr2() As Variant
    Dim rngDB As Range, rngHead As Range

    Set Ws = Sheets("Sheet1")
    Set Ws2 = Sheets("Sheet2")

    With Ws
        c = .Cells(3, Columns.Count).End(xlToLeft).Column
        r = .Range("c" & Rows.Count).End(xlUp).Row
        Set rngHead = .Range("c3", .Cells(3, c))
        arr1 = .Range("c3", .Cells(r, c))
    End With
    With Ws2
        c = .Cells(3, Columns.Count).End(xlToLeft).Column
        Set rngDB = .Range("c3", .Cells(r, c))
        arr2 = rngDB
     End With

    For j = 1 To UBound(arr2, 2)
        p = WorksheetFunction.Match(arr2(1, j), rngHead, 0)
        For i = 2 To UBound(arr2, 1)
            arr2(i, j) = arr1(i, p)
        Next i
    Next j
    rngDB = arr2
End Sub

Answer 3

Пожалуйста, попробуйте этот код.

Option Explicit

Sub CopyColumns()

    Const CaptionRow As Long = 3                    ' on all sheets
    Const FirstClm As Long = 3                      ' on all sheets

    Dim WsIn As Worksheet                           ' Input sheet
    Dim WsOut As Worksheet                          ' Output sheet
    Dim DateRange As Range                          ' dates on WsIn
    Dim Cin As Long                                 ' input column
    Dim Rl As Long                                  ' last row in WsIn
    Dim Cl As Long                                  ' last used column in WsOut
    Dim C As Long                                   ' column counter in WsOut
    Dim Arr As Variant                              ' transfer values

    Set WsIn = Worksheets("Sheet1")
    Set WsOut = Worksheets("Sheet2")

    With WsIn
        Set DateRange = .Range(.Cells(CaptionRow, FirstClm), .Cells(CaptionRow, .Columns.Count).End(xlToLeft))
    End With

    With WsOut
        Cl = .Cells(CaptionRow, .Columns.Count).End(xlToLeft).Column
        For C = FirstClm To Cl
            On Error Resume Next
            Cin = Application.Match(.Cells(CaptionRow, C).Value2, DateRange, 0)
            If Err = 0 Then
                Cin = Cin + DateRange.Column - 1
                Rl = WsIn.Cells(WsIn.Rows.Count, Cin).End(xlUp).Row
                Arr = WsIn.Range(WsIn.Cells(CaptionRow + 1, Cin), WsIn.Cells(Rl, Cin)).Value
                .Cells(CaptionRow + 1, C).Resize(UBound(Arr)).Value = Arr
            End If
        Next C
    End With
End Sub