求助如何 通过vba实现条件提取

wenbai0626

quqiyuan 发表于 2024-5-8 11:03
不是，你要看我的程序，我的这样改就可以的

可以了，但是有个问题哈，比如说我把结果表里面的数据清空，再运行，表头就是空白的


还有就是如果我在数据源里面新增了一列，结果表里面的表头就会错位

quqiyuan

wenbai0626 发表于 2024-5-8 11:22
可以了，但是有个问题哈，比如说我把结果表里面的数据清空，再运行，表头就是空白的

把这里处理一下就可以了

wenbai0626

quqiyuan 发表于 2024-5-8 11:45
把这里处理一下就可以了

非常感谢，可以啦

浦东坡

[u

Sub 筛选()
    Dim i, j, m, k, rng, rngs
    m = 1
    k = 1
    i = Application.CountA(Sheet1.[d:d])
    j = Application.CountA(Sheet1.[a:a])
    For Each rng In Sheet2.Range("a2", "a" & j)
        For Each rngs In Sheet1.Range("d2", "d" & i)
            If rng = rngs Then
                m = m + 1
                k = k + 1
                Sheet1.Range("a" & k).EntireRow.Copy Sheet4.Cells(m, "a")
            End If
        Next rngs
    Next rng
End Sub

rl="G:\练习\筛选练习\putongpo.zip"]交流[/url]

浦东坡

[ur

1. Sub 筛选()
   
2.     Dim i, j, m, k, rng, rngs
   
3.     m = 1
   
4.     k = 1
   
5.     i = Application.CountA(Sheet1.[d:d])
   
6.     j = Application.CountA(Sheet1.[a:a])
   
7.     For Each rng In Sheet2.Range("a2", "a" & j)
   
8.         For Each rngs In Sheet1.Range("d2", "d" & i)
   
9.             If rng = rngs Then
   
10.                 m = m + 1
    
11.                 k = k + 1
    
12.                 Sheet1.Range("a" & k).EntireRow.Copy Sheet4.Cells(m, "a")
    
13.             End If
    
14.         Next rngs
    
15.     Next rng
    
16. End Sub

复制代码

l="G:\练习\筛选练习\putongpo.zip"]交流[/url]