求助将另一个工作表中子项目名称复制到该项目下方，谢谢

wangweihebtu

举例：sheet1表格中有一个表格，C列为项目名称，第一个为“头皮肿物切除术”

在sheet2中A列去查找包含此关键词的数据，找到的数据共有5行，第一行与之相同，下边有四行为分项目

将sheet1中“头皮肿物切除术”行下新增四行，将分项目粘贴过来

然后从下一行继续执行以上操作，但是不都是四行，有的有十来行需要粘贴

有的可能只有一个，甚至可能有的没有查询结果（这样的都不用新增），所以这种不规则的我就整不了了，求助，谢谢

qdtzq

排序就能解决吧？

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim flg As Boolean
   
5.     tt = Timer
   
6.     With Worksheets("sheet2")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         brr = .Range("a2:a" & r)
   
9.     End With
   
10.     With Worksheets("sheet1")
    
11.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
12.         arr = .Range("a3:l" & r)
    
13.         ReDim crr(1 To UBound(arr) * 100, 1 To UBound(arr, 2))
    
14.         m = 0
    
15.         For i = 1 To UBound(arr)
    
16.             m = m + 1
    
17.             For j = 1 To UBound(arr, 2)
    
18.                 crr(m, j) = arr(i, j)
    
19.             Next
    
20.             flg = False
    
21.             For k = 1 To UBound(brr)
    
22.                 If brr(k, 1) Like arr(i, 3) & "*" Then
    
23.                     m = m + 1
    
24.                     crr(m, 3) = brr(k, 1)
    
25.                     flg = True
    
26.                 Else
    
27.                     If flg Then
    
28.                         Exit For
    
29.                     End If
    
30.                 End If
    
31.             Next
    
32.         Next
    
33.     End With
    
34.     With Worksheets("sheet3")
    
35.         .Range("a2").Resize(m, UBound(crr, 2)) = crr
    
36.     End With
    
37.     MsgBox Timer - tt
    
38. End Sub
    

复制代码

chxw68

结果在Sheet3中。

wangweihebtu

chxw68 发表于 2024-8-16 11:28
结果在Sheet3中。

十分感谢！不要匹配出的第一个，因为第一个重复，我试试我能修改下不，感谢！

扇扇扇

练习练习，运行时间3分钟

chxw68

修改好了。

Qs18

Sub qs()
Dim arr, i
arr = Sheet1.Range("a3:c" & Sheet1.Cells(Rows.Count, 3).End(xlUp).Row).Value
brr = Sheet2.Range("a1:c" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row).Value
ReDim crr(1 To 100000, 1 To 3)
For i = 1 To UBound(arr)
    s = arr(i, 3)
    For j = 1 To UBound(brr)
        If brr(j, 1) = s Then
            m = m + 1
            crr(m, 1) = arr(i, 1)
            crr(m, 2) = arr(i, 2)
            crr(m, 3) = arr(i, 3)
        ElseIf brr(j, 1) Like s & "*" Then
            m = m + 1
            crr(m, 3) = brr(j, 1)
        End If
    Next
Next
With Sheet3
.Range("a3").Resize(m, 3) = crr
End With
End Sub

Qs18

试试............

Qs18

试试.............