[求助] 批量的对应复制粘贴-2

LVMJ2023

各位老师好，请指教

清风竹-

请看附件。

LVMJ2023

清风竹- 发表于 2023-2-6 18:54
请看附件。

谢谢老师，试了下，a列要对应得行数太多时，只显示到a2:a19，不过我自己改了，感谢

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim regEx As Object, ar, br, i&, j&, Matches, iPosCol&, dic As Object
   
    Set dic = CreateObject("Scripting.Dictionary")
    ar = Range("A2", Cells(Rows.Count, "A").End(xlUp))
    ReDim br(1 To UBound(ar), 1 To 26)
   
    With Sheets("分组")
        With .[A2].CurrentRegion
           dic("a") = Intersect(.Offset(0), .Offset(, 1))
        End With
        With .[A9].CurrentRegion
           dic("b") = Intersect(.Offset(0), .Offset(, 1))
        End With
    End With
    Set regEx = CreateObject("Vbscript.RegExp")
       With regEx
            .Pattern = "(\d{1})\-(\d{1})([ab]{1})([ab]{1})均\((\d+)\)"
            For i = 1 To UBound(ar)
              If .test(ar(i, 1)) Then
              Set Matches = .Execute(ar(i, 1))
                 With Matches(0)
                    iPosCol = (Val(.submatches(0)) - 1) * 7
                    For j = 1 To 5
                       br(i, iPosCol + j) = dic(.submatches(2))(j, Val(.submatches(4)))
                    Next j
                     iPosCol = (Val(.submatches(1)) - 1) * 7
                    For j = 1 To 5
                       br(i, iPosCol + j) = dic(.submatches(3))(j, Val(.submatches(4)))
                    Next j
                 End With
              End If
            Next i
       End With
   
    [N2].Resize(UBound(ar), 26) = br
    Set dic = Nothing
    Set regEx = Nothing
    Beep
End Sub

gwjkkkkk

参与一下。。。