根据条件。通Excel VBA批量数据提取，根据条件提取所有数据

蜡笔小新a

通Excel VBA批量数据提取，根据条件提取所有数据。

现在是通过手动复制粘贴和函数 公式或者条件 格式， 弄多  EXCEL表格卡得要死，求大神指导

quqiyuan

参与一下，供参考。。。

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, i&, Rng As Range
   
    Application.ScreenUpdating = False
  
    With Worksheets(1).[A1].CurrentRegion
        ar = .Value
        .Offset(1).Interior.Color = xlNone
        Set Rng = .Rows("1:2")
        For i = 2 To UBound(ar)
            If ar(i, 13) = "已发货" Then
               Set Rng = Union(Rng, .Rows(i))
               .Rows(i).Interior.Color = RGB(198, 224, 120)
            End If
        Next i
    End With
   
    With Worksheets(2)
        .Cells.Clear
        Rng.Copy .[A1]
        .Activate
    End With

    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

............

蜡笔小新a

gwjkkkkk 发表于 2024-8-1 09:51
............

你好，我还是项搞清楚，如果我表格数据每天更新，数据比较多。当我更新当前状态为“已发货”另外的表好像没复制到sheet2里

边缘码农

更新状态后，要执行代码：

心的启点

试后反馈！

数据表.rar (24.64 KB, 下载次数: 8)

2024-8-1 17:23 上传

点击文件名下载附件

Qs18

Sub qs()
Dim arr, i, rng As Range, dic As Object
Set dic = CreateObject("scripting.dictionary")
With Sheet1
arr = Sheet1.Range("a1").CurrentRegion.Value
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 3 To UBound(arr)
    s = arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 4)
    If Not dic.exists(s) Then
        dic(s) = ""
    Else
        m = m + 1
        For j = 1 To UBound(arr, 2)
            brr(m, j) = arr(i, j)
        
        Next
    End If
Next
End With
Sheet2.Range("a3:z10000").ClearContents
Sheet2.Range("a3").Resize(m, UBound(arr, 2)) = brr
Beep
End Sub

Qs18

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

Qs18

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