Question

求Excel vba字典加数组转换出想要的数据,谢谢！

如下图片举例说明,原数据有很多行,求Excel Vba代码,谢谢！

Answer 1

Sub test()
Dim crr()
Dim row1, row2, row3, arr, brr, i, j, n
row1 = Range("A65536").End(xlUp).Row
row2 = Range("D65536").End(xlUp).Row
row3 = Range("H65536").End(xlUp).Row
arr = Range("A2:B" & row1)
brr = Range("D2:F" & row2)
For i = 1 To UBound(arr, 1)
    For j = 1 To UBound(brr, 1)
        If arr(i, 1) = brr(j, 1) Then
            n = n + 1
            ReDim Preserve crr(1 To 3, 1 To n)
            crr(1, n) = arr(i, 2)
            crr(2, n) = brr(j, 2)
            crr(3, n) = brr(j, 3)
        End If
    Next j
Next i
If row3 > 1 Then
    Range("H2:J" & row3).ClearContents
End If
Range("H2").Resize(n, 3) = Application.Transpose(crr)
End Sub

追问

数据多的时候arr和brr会提示下标越界,最后结果无法输出，能帮忙看下怎么回事吗,谢谢！

追答

方便的话
将例表上传来看看吧
光是这样的描述找不到出错原因的

追问

可以提供一下您的邮箱地址吗,excel附件好像无法上传,谢谢您！

Answer 2

应该没错~
Private Sub CommandButton1_Click()
Dim hx1, hx2, h
h = 2
For hx1 = 1 To WorksheetFunction.CountA(Columns(1)) - 1
For hx1 = 2 To WorksheetFunction.CountA(Columns(4)) - 1
If Cells(hx1 + 1, 1) = Cells(hx2 + 1, 4) Then
Cells(h, 8) = Cells(hx1 + 1, 2)
Cells(h, 9) = Cells(hx2 + 1, 5)
Cells(h, 10) = Cells(hx2 + 1, 6)
h = h + 1
End If
Next
Next
End Sub