恳请大神帮忙看下这个咋用代码达到我想要的结果

qiongmei6

我想求得一个代码，当他执行的时候，他根据y3：ao124列中，找出y列中“改制职工”中z列没有厨房的y3：ao124的内容填入au：bi列，并将y列中“改制职工”中z列有厨房的y3：ao124的内容填入bo：cc列，目前的au：bi列和bo：cc列就是我希望得到的最后结果，再次谢谢各位大神的帮忙。

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br, i&, j&
   
    With Range("Y1", Cells(Rows.Count, "AO").End(xlUp))
        ar = .Value
        ReDim br(1 To 2)
        With Intersect(.Offset(), .Offset(, 2))
            For j = 1 To 2
                Set br(j) = .Rows("1:2")
            Next j
            For i = 3 To UBound(ar)
                If ar(i, 1) = "改制职工" Then
                    If ar(i, 2) = 0 Then
                        Set br(1) = Union(br(1), .Rows(i))
                    ElseIf ar(i, 2) = "厨房" Then
                        Set br(2) = Union(br(2), .Rows(i))
                    End If
                End If
            Next i
        End With
    End With
   
   For i = 1 To 2
       Cells(1, (i - 1) * 20 + 47).CurrentRegion.Delete Shift:=xlUp
       br(i).Copy Cells(1, (i - 1) * 20 + 47)
   Next i
    Beep
End Sub

gwjkkkkk

请参考附件。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.22
   
2.     r = Me.Cells(Rows.Count, "y").End(3).Row
   
3.     arr = Me.Range("y3:ao" & r)
   
4.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) - 2)
   
5.     ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2) - 2)
   
6.     For i = 1 To UBound(arr)
   
7.         If arr(i, 1) = "改制职工" Then
   
8.             st = CStr(arr(i, 2))
   
9.             If InStr(st, "厨房") = 0 Then
   
10.                 m = m + 1
    
11.                 For j = 3 To UBound(arr, 2)
    
12.                     brr(m, j - 2) = arr(i, j)
    
13.                 Next
    
14.             Else
    
15.                 n = n + 1
    
16.                 For j = 3 To UBound(arr, 2)
    
17.                     crr(n, j - 2) = arr(i, j)
    
18.                 Next
    
19.             End If
    
20.         End If
    
21.     Next
    
22.     Me.[au3:bi10000] = ""
    
23.     Me.[bo3:cc10000] = ""
    
24.     Me.[au3].Resize(m, UBound(brr, 2)) = brr
    
25.     Me.[bo3].Resize(n, UBound(crr, 2)) = brr
    
26.     MsgBox "OK！"
    
27. End Sub
    
28. 
    

复制代码

ykcbf1100

附件供参考。。。