[已解决]求助：VBA在海量药品中，提取需要的药品

yjwdjfqb · 发表于 2014-10-6 10:43

求助：VBA在海量药品中，提取需要的药品

当运行VBA时，弹出对话框，选择“需要提取的药品列”，及“总药品列”

确定后，提取到需要的药品，就像文件中的手工表一样

请老师们帮帮忙，谢谢大家了!

VBA提取药品.rar (36.22 KB, 下载次数: 32)

xdragon · 发表于 2014-10-6 11:23

本帖最后由 xdragon 于 2014-10-6 11:25 编辑

Sub 宏1()
Dim rng As Range
On Error GoTo endline
Set rng = Application.InputBox("请选择需要提取的药品列", "提示", , , , , , 8)
Set rng = Intersect(rng.Parent.UsedRange, rng)
Sheets("手工结果").Select
cells.clear
Sheets("全部药品").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=rng, CopyToRange:=Range("A1"), _
Unique:=False
endline:
End Sub

复制代码

利用高级筛选录制宏就能搞定啦

忘记在导出结果前清空工作表了。加了一行

QLZ0602 · 发表于 2014-10-6 11:32

VBA提取药品.rar (374.46 KB, 下载次数: 18)

yjwdjfqb · 发表于 2014-10-6 20:54

xdragon 发表于 2014-10-6 11:23
利用高级筛选录制宏就能搞定啦

忘记在导出结果前清空工作表了。加了一行

老师你好，我测试了下，提取的数据不对

数据应该是手工表中那些内容

xdragon · 发表于 2014-10-7 01:34

yjwdjfqb 发表于 2014-10-6 20:54
老师你好，我测试了下，提取的数据不对

数据应该是手工表中那些内容

只是顺序不一致，内容都对啊。你需要结果和你那张表一模一样吗？。。。

huizhiaisha · 发表于 2014-10-7 11:12

本帖最后由 huizhiaisha 于 2014-10-7 11:19 编辑

我日文系统，传不了附件，你留个邮箱发给你

yjwdjfqb · 发表于 2014-10-7 12:49

xdragon 发表于 2014-10-7 01:34
只是顺序不一致，内容都对啊。你需要结果和你那张表一模一样吗？。。。

哦，只要内容一样就行了，谢谢老师！
我再核对下数据，非常的感谢！

yjwdjfqb · 发表于 2014-10-8 11:50

QLZ0602 发表于 2014-10-6 11:32
是不是这样？

Sub demo()
Dim rng1 As Range, rng2 As Range, nr As Long, nc As Long
Dim i, j, k, n
Dim arr, brr, crr, drr
On Error Resume Next
Set rng1 = Application.InputBox("请选择需要提取的药品列", "选择", , , , , , 8)
If rng1 Is Nothing Then Exit Sub
On Error Resume Next
Set rng2 = Application.InputBox("请选择全部药品列", "选择", , , , , , 8)
If rng2 Is Nothing Then Exit Sub
With Sheets("全部药品")
      nr = .Cells(Rows.Count, 1).End(xlUp).Row
      nc = .Cells(1, Columns.Count).End(xlToLeft).Column
      arr = .Range(.Cells(1, 1), .Cells(nr, nc))
      brr = rng1.Value
      crr = rng2.Value
      ReDim drr(1 To UBound(arr), 1 To UBound(arr, 2))
      For i = 2 To UBound(arr)
         For j = 1 To UBound(crr)
            If brr(j, 1) = "" Then Exit For
            If brr(j, 1) = crr(i, 1) Then
                  n = n + 1
                  For k = 1 To UBound(arr, 2)
                     drr(n, k) = arr(i, k)
                  Next
                  Exit For
            End If
         Next
      Next
      For k = 1 To UBound(arr, 2)
         drr(1, k) = arr(1, k)
      Next
End With
With Sheets("模拟")
      .Cells.Clear
      .Range("a1").Resize(n, UBound(drr, 2)) = drr
End With
End Sub

老师你好，这个可以，但是提取时，没有带格式提取

请老师帮帮我修改下，可以带格式提取，好吧，谢谢老师了！

grf1973 · 发表于 2014-10-8 15:15

如果按“全部药品”表的顺序。。。。。。。。。

Sub demo()
Dim CopyRng As Range
Set d = CreateObject("scripting.dictionary")
brr = Sheets("需提取药品").[d2].CurrentRegion
With Sheets("全部药品")
arr = .[a1].CurrentRegion
Set CopyRng = .[a1:o1]
For i = 2 To UBound(arr)
d(arr(i, 3)) = d(arr(i, 3)) & "," & i
Next
For i = 2 To UBound(brr)
k = d(brr(i, 1))
If Len(k) > 0 Then
krr = Split(k, ",")
For j = 1 To UBound(krr)
x = Val(krr(j))
Set CopyRng = Union(CopyRng, .Range("a" & x & ":o" & x))
Next
End If
Next
End With
With Sheets("手工结果")
.Cells.Clear
CopyRng.Copy .[a1]
End With
End Sub

复制代码

grf1973 · 发表于 2014-10-8 15:20

如果按“需提取药品”表的顺序。。。。。。。。。

Sub demo()
Dim Sh As Worksheet
Set Sh = Sheets("手工结果")
Set d = CreateObject("scripting.dictionary")
brr = Sheets("需提取药品").[d2].CurrentRegion
Sh.Cells.Clear
With Sheets("全部药品")
arr = .[a1].CurrentRegion
.[a1:o1].Copy Sh.[a1]
For i = 2 To UBound(arr)
d(arr(i, 3)) = d(arr(i, 3)) & "," & i
Next
For i = 2 To UBound(brr)
k = d(brr(i, 1))
If Len(k) > 0 Then
krr = Split(k, ",")
For j = 1 To UBound(krr)
x = Val(krr(j))
n = n + 1
.Range("a" & x & ":o" & x).Copy Sh.Cells(n + 1, 1)
Sh.Cells(n + 1, 1) = n
Next
End If
Next
End With
End Sub

复制代码

		自动登录	找回密码
密码			注册

[已解决]求助：VBA在海量药品中，提取需要的药品

相关帖子

评分

评分