当sheet1表中B列出现的部分代码与A类别信息信息相同时复制sheet2内

fengye5200

各位大神，求助！

当sheet1中B列代码在A列相同出现后，将A列对应单元格数值剪切到sheet2对应单元格内，信息如下：


谢谢！

longwin

等等附件吧

fengye5200

增加附件，求助各位！

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.1
   
2.     With Sheets("Sheet1")
   
3.         r = .Cells(Rows.Count, 2).End(3).Row
   
4.         arr = .[a1].Resize(r, 2)
   
5.     End With
   
6.     ReDim brr(1 To 100)
   
7.     For i = 2 To UBound(arr)
   
8.         If InStr(arr(i, 1), arr(i, 2)) Then
   
9.             c = c + 1
   
10.             brr(c) = arr(i, 1)
    
11.         End If
    
12.     Next
    
13.     With Sheets("Sheet2")
    
14.         .UsedRange.Offset(1).ClearContents
    
15.         .[a2].Resize(, c) = brr
    
16.     End With
    
17.     MsgBox "OK！"
    
18. End Sub
    
19. 
    

复制代码

usedrange

参与一下

1. Private Sub CommandButton1_Click()
   
2.     Dim arr, i%, j%, br, crr, d
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     With Sheet1
   
5.         arr = .[a2].Resize(.[a2].End(4).Row, 1)
   
6.         br = .[b2].Resize(.[b2].End(4).Row, 1)
   
7.         ReDim crr(1 To UBound(arr), 1 To UBound(br))
   
8.         For i = 1 To UBound(arr)
   
9.             For j = 1 To UBound(br)
   
10.                 If InStr(arr(i, 1), br(j, 1)) Then
    
11.                     d(br(j, 1)) = d(br(j, 1)) + 1
    
12.                     crr(1, j) = br(j, 1)
    
13.                     crr(d(br(j, 1)) + 1, j) = arr(i, 1)
    
14.                     Exit For
    
15.                 End If
    
16.             Next j
    
17.         Next i
    
18.     End With
    
19.     Sheet2.[a1].Resize(UBound(crr), UBound(br)) = crr
    
20.     Set d = Nothing
    
21. End Sub
    

复制代码