求助老师VBA提取同样的，我用组里搜来的代码修改后，执行错误

lixinlin181818

求助老师VBA提取同样的并填充，我用组里搜来的代码修改后，执行错误

quqiyuan

简单修改了下，仅供参考。。。

Qs18

1. Sub qs()
   
2. Dim arr, i, s
   
3. With Sheet3
   
4.     s = [AA2]
   
5.     arr = .Range("e5:O104")
   
6.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
7.     For i = 1 To UBound(arr)
   
8.         If arr(i, 1) = s Then
   
9.             m = m + 1
   
10.             For j = 1 To UBound(arr, 2)
    
11.                 brr(m, j) = arr(i, j)
    
12.             Next
    
13.         End If
    
14.     Next
    
15. .Range("AA5").Resize(10000, UBound(arr, 2)) = Empty
    
16. .Range("AA5").Resize(m, UBound(arr, 2)) = brr
    
17. End With
    
18. End Sub
    

复制代码

Qs18

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

quqiyuan

代码如下。。
Sub test()
    Dim arr1, arr2(), x, y, k, St$
    St = Sheets("41周").Range("AA2").Value
    St = IIf(St <> "", St, Sheets("41周").Range("AA5").Value)
    r = Sheets("41周").Cells(Rows.Count, 5).End(3).Row
    arr1 = Sheets("41周").Range("A1").CurrentRegion.Resize(r)
    k = 0
    For x = 5 To UBound(arr1)
        If arr1(x, 5) = St Then
            k = k + 1
            If k = 1 Then
                ReDim arr2(1 To UBound(arr1, 2) - 4, 1 To 1)
            Else
                ReDim Preserve arr2(1 To UBound(arr1, 2) - 4, 1 To k)
            End If
            For y = 5 To 15
                arr2(y - 4, k) = arr1(x, y)
            Next y
        End If
    Next x
    Sheets("41周").Range("AA5:AK10").ClearContents
    If k > 0 And UBound(arr1, 2) > 0 Then
        Sheets("41周").Range("AA5").Resize(k, UBound(arr1, 2)) = Application.WorksheetFunction.Transpose(arr2)
    Else
        MsgBox "数据处理出现问题，无法写入到工作表。请检查数据。"
    End If
End Sub

Qs18

试试.........

lixinlin181818

quqiyuan 发表于 2024-10-9 21:32
简单修改了下，仅供参考。。。

厉害，谢谢老师，完美解决问题

lixinlin181818

Qs18 发表于 2024-10-9 21:33
试试.........

太感谢老师了，还是不一样代码。