VBA 前缀左右互相配对 ( 难度高 )

On_fire

gwjkkkkk 发表于 2024-1-25 21:01
Option Explicit
Sub TEST1()
    Dim ar, br, i&, j&, r&, strReplace$

大神们, 老师们好,
源数据有这个情况,
1. [AA19:AB32]同两列由上到下的行数是变量
2. [AE52:AR52]同一行由左到右的列数也是变量
*
请您看看文件的模拟,
如果[AA19:AB32]的行数是变量,
如[AE52:AR52]的前缀能配对上, 就出结果,
如配对不上就留空白, 这个代码要如何优化呢?

gwjkkkkk

On_fire 发表于 2024-1-26 11:01
大神们, 老师们好,
源数据有这个情况,
1. [AA19:AB32]同两列由上到下的行数是变量

请参考附件。。。

On_fire

gwjkkkkk 发表于 2024-1-26 19:26
请参考附件。。。

再次感谢老师…

On_fire

gwjkkkkk 发表于 2024-1-26 19:26
请参考附件。。。

老师好,
抱歉, 又要麻烦您帮帮忙…
现在的数据是[AA19:AD32]同行共四列, 由上到下的行数是变量!
每个对上号的各输出同列4行, 请问文件中的代码如何优化?

gwjkkkkk

Sub TEST1()
    Dim ar, br, cr, i&, j&, r&, strReplace$
   
    With [AA19].CurrentRegion
        ar = .Value
        ReDim Preserve ar(1 To UBound(ar), 1 To 7)
        For i = 1 To UBound(ar)
            ar(i, 1) = Replace(ar(i, 1), " ", "")
            For j = 4 To UBound(ar, 2)
                Set ar(i, j) = .Cells(i, j - 3)
            Next j
            ar(i, 2) = Split(ar(i, 1), ".")(0)
            ar(i, 3) = Split(ar(i, 1), ".")(1)
        Next i
    End With
    Rows("53:" & Rows.Count).Clear
    With [AE52].CurrentRegion
        br = .Value
        For j = 1 To UBound(br, 2)
            r = 15
            strReplace = Replace(br(1, j), " ", "")
            cr = Split(strReplace, ".")
            For k = 1 To UBound(ar)
                If ar(k, 3) = cr(0) Then
                    For i = 4 To UBound(ar, 2)
                        r = r + 1
                        ar(k, i).Copy .Cells(r, j)
                    Next i
                End If
            Next k
            For k = 1 To UBound(ar)
                If ar(k, 2) = cr(1) Then
                    For i = 4 To UBound(ar, 2)
                        r = r + 1
                        ar(k, i).Copy .Cells(r, j)
                    Next i
                End If
            Next k
        Next j
    End With
    Beep
End Sub

gwjkkkkk

请参考。。。

On_fire

gwjkkkkk 发表于 2024-2-1 20:20
请参考。。。

再…再一次感谢老师…