麻烦老师写个匹配对应结果的代码

不可说7625

把sheet1中C、D列的值在Sheet2 对应列分别出来

一、
比如sheet1 C3=亲疏疏，D3=加减加
在sheet2 G4显示亲疏疏，O3显示加减加并标红，其他没有匹配的数值，以序列填充，得出的数值下期重新以1开始重新编号。
如图


后面的以此类推。



二、统计下D列到T列，每列对应出现的最大次数


三、加个按钮运行，谢谢。

不可说7625

有大神来整下吗？

longwin

请测试。。。。

不可说7625

longwin 发表于 2024-5-17 00:46
请测试。。。。

在最后增加数据，为啥没有更新？

不可说7625

longwin 发表于 2024-5-17 00:46
请测试。。。。

1、不用弄2个工作表了，直接把结果放在sheet1后面，如图。



2、7934行后面，还会新增数据，


能麻烦在修改下吗？

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, cr, i&, j&, r&, k&, dic As Object, strJoin$
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Sheets(1).[A1].CurrentRegion.Value
    For i = 2 To UBound(ar)
        strJoin = ar(i, 1) & "," & ar(i, 2)
        dic(strJoin) = Array(ar(i, 3), ar(i, 4))
    Next i

    r = Cells(Rows.Count, "A").End(xlUp).Row
    br = Range("A2:B" & r).Value
   
    ReDim ar(1, 1)
    For j = 0 To UBound(ar, 2)
        Range(Cells(2, j * 8 + j + 4), Cells(r, j * 8 + j + 11)).Offset(1).Clear
        Set ar(1, j) = Range(Cells(2, j * 8 + j + 4), Cells(r, j * 8 + j + 11))
        ar(0, j) = ar(1, j).Value
    Next j
   
    For i = 2 To UBound(br)
        strJoin = br(i, 1) & "," & br(i, 2)
        If dic.exists(strJoin) Then
             cr = dic(strJoin)
             For j = 0 To 1
                 For k = 1 To UBound(ar(0, j), 2)
                     If ar(0, j)(1, k) = cr(j) Then
                         ar(0, j)(i, k) = cr(j)
                         ar(1, j).Cells(i, k).Interior.Color = vbRed
                         Exit For
                     End If
                 Next k
             Next j
        End If
    Next i
   
    For j = 0 To UBound(ar, 2)
        For i = 1 To UBound(ar(0, j), 2)
            r = 0
            For k = 2 To UBound(ar(0, j))
                If Len(ar(0, j)(k, i)) = False Then
                    r = r + 1
                    ar(0, j)(k, i) = r
                Else
                    r = 0
                End If
            Next k
        Next i
        Cells(2, j * 8 + j + 4).Resize(UBound(ar(0, j)), UBound(ar(0, j), 2)) = ar(0, j)
    Next j
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

不可说7625

gwjkkkkk 发表于 2024-5-18 11:06
请参考附件。。。

没啥大问题，有个小问题，发现不用新建个工作表，直接在sheet1 F列后显示sheet2 C列到T列的结果，如图


sheet2表不用。能改下吗？

gwjkkkkk

不可说7625 发表于 2024-5-18 15:59
没啥大问题，有个小问题，发现不用新建个工作表，直接在sheet1 F列后显示sheet2 C列到T列的结果， ...

.......................

不可说7625

gwjkkkkk 发表于 2024-5-18 18:32
.......................

有2个问题


1、最大值，没有计算出来，能在改下吗？


2、24128新增数据，运行显示这个