如何将总表中符合条件的数据筛选后提取到新表中

jyapngpang

各位大神求帮忙！！！就是我想筛选“银行间成交回报”这页里J列委托方向为：“债券买入”、“债券卖出”的数据，然后选择数据所在行中的某些指定单元格，将放置在“发送数据”这页里，附件为所需筛选数据模板，求告知怎么用vba实现，跪谢~

dsmch

1. Sub dsmch()
   
2. Dim arr, brr, crr, d, i&, j%, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. t1 = "债券卖出": t2 = "债券买入"
   
5. arr = Sheet1.Range("a1").CurrentRegion
   
6. brr = Sheet2.Range("a1").CurrentRegion
   
7. ReDim crr(1 To 20000, 1 To UBound(brr, 2))
   
8. For j = 1 To UBound(arr, 2)
   
9.     d(arr(1, j)) = j
   
10. Next
    
11. For i = 2 To UBound(arr)
    
12.     If arr(i, 10) = t1 Or arr(i, 10) = t2 Then
    
13.         s = s + 1
    
14.         For j = 1 To UBound(brr, 2)
    
15.             n = d(brr(1, j))
    
16.             crr(s, j) = arr(i, n)
    
17.         Next
    
18.     End If
    
19. Next
    
20. Sheet2.Range("a2").Resize(s, UBound(crr, 2)) = crr
    
21. End Sub

复制代码

jyapngpang

dsmch 发表于 2018-12-13 15:41

大神，我复制运行的时候报错 运行到？？d(arr(i,j))=j的时候说语法错误

dsmch

………………

jyapngpang

dsmch 发表于 2018-12-14 10:59
………………

好厉害，感谢~~~

cjc209

设置好表名称为tj的条件表
委托方向
债券卖出
债券买入
然后 按操作步骤运行及可 通用型

1. Sub 单簿多表高级筛选()
   
2.      Dim Sht As Worksheet
   
3.      Dim xRow As Integer
   
4.      Dim yRow As Integer
   
5.      Sheets.Add After:=Sheets(Sheets.Count)
   
6.      ActiveSheet.Name = "合并结果"
   
7.      qsh = Val(Application.InputBox("请输入表头最末行号：", "拆分表格", "1"))
   
8.      bw = Val(Application.InputBox("请输入表尾的总行数， 没有就默认为0：", "拆分表格", "0"))
   
9.      Sheets("tj").Activate
   
10.      Set sxtj = Application.InputBox("请框选已设置好了的_ _筛选条件区域 ：", Type:=8)
    
11.      a = MsgBox("是否去重处理", vbYesNo)
    
12.      Sheets("合并结果").Activate
    
13.      Application.ScreenUpdating = False
    
14.      Application.DisplayAlerts = False
    
15.      For Each Sht In Worksheets
    
16.           bm = ActiveSheet.Name
    
17.           If Sht.Name <> bm And Sht.UsedRange.Rows.Count + Sht.UsedRange.Row - 1 > 1 And Sht.Name <> "tj" Then
    
18.             xRow = Sht.UsedRange.Rows.Count + Sht.UsedRange.Row - 1
    
19.               ls2 = Sht.UsedRange.Columns.Count + Sht.UsedRange.Column - 1
    
20.          Set myRange = Cells(1, ls2)    '指定该列标号的任意单元格
    
21.           zmlh2 = Left(myRange.Range("A1").Address(True, False), _
    
22.           InStr(1, myRange.Range("A1").Address(True, False), "$", 1) - 1)
    
23.              If xRow > 1 Then
    
24.              yRow = Worksheets(bm).UsedRange.Rows.Count + Worksheets(bm).UsedRange.Row - 1
    
25.              If n > 0 Then GoTo 10
    
26.              Sht.Range("a1:" & zmlh2 & xRow - bw).Copy Worksheets(bm).Range("a" & yRow)
    
27.              GoTo 11
    
28. 10:
    
29.              Sht.Range("A" & qsh + 1 & ":" & zmlh2 & xRow - bw).Copy Worksheets(bm).Range("a" & yRow + 1)
    
30.              End If
    
31. 11:
    
32.              n = n + 1
    
33.          End If
    
34.      Next
    
35.      If qsh > 1 Then
    
36.      Rows("1:" & qsh - 1).Delete
    
37.     End If
    
38.      Application.ScreenUpdating = True
    
39.      Set zzd = Application.InputBox(prompt:="请选择这里提取需要的字段：点选按住Ctrl键 连续的可以框选）：", Type:=8)
    
40.      Application.ScreenUpdating = False
    
41.      Sheets.Add After:=ActiveSheet
    
42.      ActiveSheet.Name = "筛选结果"
    
43.      For Each zd In zzd
    
44.      ss = ss + 1
    
45.       Cells(1, ss) = zd.Value
    
46.      Next zd
    
47.      For Each Sht In Sheets
    
48.         If Sht.Name = "合并结果" Then
    
49.             Myr = Cells(Rows.Count, 1).End(xlUp).Row + 1
    
50.             If Myr = 2 Then Myr = 1
    
51.             If a = 7 Then
    
52.               Sht.UsedRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=sxtj, CopyToRange:=Range(Cells(1, 1), Cells(1, ss)), Unique:=False
    
53.             Else
    
54.               Sht.UsedRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=sxtj, CopyToRange:=Range(Cells(1, 1), Cells(1, ss)), Unique:=True
    
55.             End If
    
56.         End If
    
57.     Next
    
58.     Worksheets("合并结果").Delete
    
59.      Application.DisplayAlerts = True '恢复警告
    
60.      Application.ScreenUpdating = True
    
61. End Sub
    
62. 
    
63. 
    

复制代码

jyapngpang

cjc209 发表于 2018-12-14 11:18
设置好表名称为tj的条件表
委托方向
债券卖出

虽然完全看不懂，但是觉得好厉害!

jyapngpang

dsmch 发表于 2018-12-14 10:59
………………

还想请教下，就是如果我sheet1数据更新了，再执行宏的时候，原来的数据还在，怎样在再次执行宏之前将原数据清空呢？

dsmch

20.Sheet2.Range("a2").Resize(s, UBound(crr, 2)) = crr改为：
sheet2.activate
activesheet.usedrange.clear
Range("a2").Resize(s, UBound(crr, 2)) = crr

jyapngpang

dsmch 发表于 2018-12-14 15:39
20.Sheet2.Range("a2").Resize(s, UBound(crr, 2)) = crr改为：
sheet2.activate
activesheet.usedrange. ...

可是这样连sheet2 页里的表头也清除了，如果不想清除表头，是从第二行开始清除呢？