Question

我无法达到匹配2D阵列的工作条件。我尝试了另一种方法，这种方法更接近解决方案，但仍然无法产生结果。

这就是我想要做的：

在sheet1中，我有不同的日期，这些日期经过各列，并且大小不确定。这些日期下面是值：

在工作表2中，我有一个较小的日期子集（应该在工作表1中存在）：

通过代码，我想匹配sheet1和sheet2中的日期，并且只有匹配为true时，我才想将相应的值从sheet1写入sheet2。结果就是这样：

我想使用工作表1和工作表2中的日期的数组，如果它们匹配，则编写值数组。但是日期数组变成空的，因此匹配条件不起作用。我也没有收到任何错误消息：

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

请尝试使用此代码。

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

Answer 2

您期望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 3

尝试

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

匹配2D数组并输出另一个数组的值

3 个答案: