提取或替换的请求

贺达勇

我想请老师，帮我一下，我自己的代码运行起来没有反应。




再次感谢版主的代码。

taller

taller

1. Option Explicit
   
2. ' 使用字典对象比多重循环更高效
   
3. Sub Demo()
   
4.     Dim objDic As Object, rngData As Range
   
5.     Dim i As Long, iR As Long, sKey
   
6.     Dim arrData, arrRes
   
7.     Set objDic = CreateObject("scripting.dictionary")
   
8.     Set rngData = Range("U7:X" & Cells(Rows.Count, "U").End(xlUp).Row)
   
9.     arrData = rngData.Value
   
10.     ReDim arrRes(1 To UBound(arrData) * 2, 0)
    
11.     For i = LBound(arrData) To UBound(arrData)
    
12.         If arrData(i, 1) = "T" Then
    
13.             sKey = arrData(i, 4) & "," & arrData(i, 3)
    
14.             If Not objDic.exists(sKey) Then
    
15.                 iR = objDic.Count + 1
    
16.                 objDic(sKey) = iR
    
17.             End If
    
18.         End If
    
19.     Next i
    
20.     iR = 0
    
21.     For Each sKey In objDic.keys
    
22.         iR = iR + 1
    
23.         arrRes(iR, 0) = "T(PROFP_" & objDic(sKey) & ")=TOL/PROFP," & sKey
    
24.     Next
    
25.     For i = LBound(arrData) To UBound(arrData) - 4
    
26.         If arrData(i, 1) = "DIM" And arrData(i + 4, 1) = "T" Then
    
27.             iR = iR + 1
    
28.             arrRes(iR, 0) = "OUTPUT/FA(" & arrData(i, 2) & ")"
    
29.             sKey = arrData(i + 4, 4) & "," & arrData(i + 4, 3)
    
30.             If objDic.exists(sKey) Then
    
31.                 iR = iR + 1
    
32.                 arrRes(iR, 0) = arrRes(iR - 1, 0) & ",TA(PROFP_" & objDic(sKey) & ")"
    
33.             End If
    
34.         End If
    
35.     Next i
    
36.     Range("AJ2").Resize(iR, 1) = arrRes
    
37. End Sub
    
38. 
    

复制代码

longwin

附件供参考。。。。

贺达勇

longwin 发表于 2024-10-19 11:57
附件供参考。。。。

感谢你的回复，经我的验证，不是我想要的，版主的代码是我想要的结果，谢谢你们，你们辛苦了。

贺达勇

taller 发表于 2024-10-19 11:44

感谢你的回复，经我的验证，是我想要的结果。