请大神们帮忙看下这个提取的难题

qiongmei6

我想在附件中求得一个代码，在y3：ad列，根据ad列有厨房的数据的放在ar3：av，没有厨房的放在ai3：am，目前的ai3：av就是我希望代码执行后的结果，谢谢各位大神师傅的帮忙。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.5.13
   
2.     Dim brr(1 To 10000, 1 To 5)
   
3.     Dim crr(1 To 10000, 1 To 5)
   
4.     arr = [y3:ad5]
   
5.     For i = 1 To UBound(arr)
   
6.         If arr(i, 6) = "厨房" Then
   
7.             m = m + 1
   
8.             For j = 1 To UBound(arr, 2) - 1
   
9.                 brr(m, j) = arr(i, j)
   
10.             Next
    
11.         Else
    
12.             n = n + 1
    
13.             For j = 1 To UBound(arr, 2) - 1
    
14.                 crr(n, j) = arr(i, j)
    
15.             Next
    
16.         End If
    
17.     Next
    
18.     [ai:av] = ""
    
19.     Columns("at:at").NumberFormatLocal = "@"
    
20.     [ai3].Resize(n, 5) = crr
    
21.     [ar3].Resize(m, 5) = brr
    
22.     MsgBox "OK！"
    
23. End Sub
    

复制代码

qiongmei6

ykcbf1100 发表于 2024-5-13 13:42
附件供参考。。。

非常ykcbf1100大神的帮忙，是我没考虑清楚，因此现在在执行中出现差错，如果ad列没有厨房的话，这个代码会出错，能否改成ad如果没有厨房的时候，数据到ai3：am列，ar3：av列为空，再次非常感谢您今天的所有的回答。

swl4561255

1. Sub test()
   
2. Dim myr1 As Range
   
3. Dim myr2 As Range
   
4. ar = [Y3].End(4).Row
   
5. For i = 3 To ar
   
6.     If Cells(i, "AD") = "厨房" Then
   
7.         If myr1 Is Nothing Then
   
8.             Set myr1 = Cells(i, "Y").Resize(1, 6)
   
9.         Else
   
10.             Set myr1 = Union(myr1, Cells(i, "Y").Resize(1, 6))
    
11.         End If
    
12.     Else
    
13.         If myr2 Is Nothing Then
    
14.             Set myr2 = Cells(i, "Y").Resize(1, 6)
    
15.         Else
    
16.             Set myr2 = Union(myr2, Cells(i, "Y").Resize(1, 6))
    
17.         End If
    
18.     End If
    
19. Next
    
20. myr1.Copy [AR3]
    
21. myr2.Copy [AI3]
    
22. End Sub

复制代码

ykcbf1100

qiongmei6 发表于 2024-5-13 13:58
非常ykcbf1100大神的帮忙，是我没考虑清楚，因此现在在执行中出现差错，如果ad列没有厨房的话，这个代码 ...

改一下吧。

LIUZHU

参与下，试试

LIUZHU

JSA代码，只有几行

1. function 提取数据(){
   
2.         Range("ai:av").ClearContents();
   
3.         let res=Range("y3:ad5").Value2.reduce((res,x)=>(x[5]!="厨房"?res[0].push(x):res[1].push(x),res),[[],[]]);
   
4.         [[res[0],"ai3"],[res[1],"ar3"]].forEach(([ar,ads])=>ar.length>0?Range(ads).Resize(ar.length,ar[0].length).Value2=ar:null);
   
5. }

复制代码

LIUZHU

附件请测试，需要用WPS测试

Qs18

Public Sub test()
Dim arr, br, cr
arr = Sheet10.Range("y3:ad" & Range("y65536").End(xlUp).Row)
ReDim br(1 To UBound(arr), 1 To 5)
ReDim cr(1 To UBound(arr), 1 To 5)
For i = 1 To UBound(arr)
    If arr(i, 6) = "厨房" Then
         k = k + 1
        For x = 1 To 5
           
            br(k, x) = arr(i, x)
        Next
    Else
         y = y + 1
        For j = 1 To 5
            cr(y, j) = arr(i, j)
        
        Next
    End If
Next
Sheet10.Range("AR3").Resize(k, 5) = br
Sheet10.Range("AI3").Resize(k, 5) = cr
End Sub