Match 2D arrays and output values of another array

Question

I cannot get to work condition for matching 2D arrays. I have tried another approach and this one is closer to the solution, but still does not produce the outcome.

This is what I want to do:

In sheet1 I have different dates that go through columns and size is uncertain. Below these dates are the values:

In sheet 2, I have a smaller subset of dates (that should exist in sheet1):

Through the code, I want to match the dates in sheet1 and sheet2, and only if match is true, I want to write the corresponding values from sheet1 to sheet2. This is the outcome:

I want to use Arrays for dates in sheet1 and sheet2 and if they match, write the array of values. But the arrays of dates turn to be empty and so condtion for match does not work. I am not getting any error message as well:

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

I would appreciate suggestions.

Variatus · Accepted Answer · 2019-01-21 10:38:46Z

Please try this code.

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

It works perfectly! The Resize property looks like something useful for the future, I need to learn it better. Thank you !

Cindy Meister · Accepted Answer · 2019-01-21 10:52:50Z

1

What do you expect ReDim arrDates_w2(1, Lastcol_w2) to be doing? As it stands, it's only re-sizing the number of items that can be held in the array... You need to assign the Range to it: arrDates_w2 = w2.Range("C3:K3").Value for example. This will create a multi-dimensional array.

Then you can loop the items. Here's some sample code to illustrate the principle

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

answered Jan 21, 2019 at 10:52

Cindy Meister

25.8k21 gold badges36 silver badges45 bronze badges

Comments

Dy.Lee · Accepted Answer · 2019-01-21 11:49:44Z

0

Try

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

answered Jan 21, 2019 at 11:49

Dy.Lee

7,5471 gold badge14 silver badges14 bronze badges

1 Comment

Dozens Over a year ago

You cannot use the match worksheet function for array

Collectives™ on Stack Overflow

Match 2D arrays and output values of another array

3 Answers 3

1 Comment

Comments

1 Comment

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

3 Answers 3

1 Comment

Comments

1 Comment

Your Answer

Sign up or log in

Post as a guest

Related