[已解决]VBA修改成带格式提取数据

yjwdjfqb

VBA修改成带格式提取数据

附件中，有二个地方想修改下，见图片中
请老师们帮帮忙，谢谢大家了！

VBA修改成带格式提取数据.rar (35.45 KB, 下载次数: 25)

2014-10-8 12:17 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

xdragon

2014-10-8 13:02

第一个问题：把with sheets("全部药品") 改成 with sheets(rng2.parent.name)
第二个问题：如果改成带格式会大大影响代码的运行速度，如果楼主确定可以更改。如果只是要调整最终格式，只需要在最后导出数组后，加上边框的代码 .range("A1").currentregion.border.linestyle=1
调整最合适的列间距 .range("A1").currentregion.entirecolumn.autofit

跳转到最佳答案楼层

xdragon

第一个问题：把with sheets("全部药品") 改成 with sheets(rng2.parent.name)
第二个问题：如果改成带格式会大大影响代码的运行速度，如果楼主确定可以更改。如果只是要调整最终格式，只需要在最后导出数组后，加上边框的代码 .range("A1").currentregion.border.linestyle=1
调整最合适的列间距 .range("A1").currentregion.entirecolumn.autofit

su45

1.  好办。
2. 要带格式就影响速度了。

yjwdjfqb

xdragon 发表于 2014-10-8 13:02
第一个问题：把with sheets("全部药品") 改成 with sheets(rng2.parent.name)
第二个问题：如果改成带格式 ...

感谢老师的帮助!

yjwdjfqb

xdragon 发表于 2014-10-8 13:02
第一个问题：把with sheets("全部药品") 改成 with sheets(rng2.parent.name)
第二个问题：如果改成带格式 ...

老师你好，今天，我用这个程序时，发现，数据结果不对

如，我需要的药品中，只有   参麦注射液   这一种药品
得到的结果应该有 四行数据才对

但只有三行数据，请老师帮帮斧正下好吧，谢谢老师了!

xdragon

yjwdjfqb 发表于 2014-10-9 16:42
老师你好，今天，我用这个程序时，发现，数据结果不对

如，我需要的药品中，只有   参麦注射液   这一 ...

请问你用的是谁的代码？从你附件看，我这里运行结果参麦注射液 是有四行数据的。

yjwdjfqb

xdragon 发表于 2014-10-9 19:34
请问你用的是谁的代码？从你附件看，我这里运行结果参麦注射液 是有四行数据的。

也是一个论坛的老师帮我写的，我运行后，只有三行数据。

yjwdjfqb

xdragon 发表于 2014-10-9 19:34
请问你用的是谁的代码？从你附件看，我这里运行结果参麦注射液 是有四行数据的。

老师能帮我看看问题出现在哪儿了吗，谢谢了!

xdragon

yjwdjfqb 发表于 2014-10-9 19:58
老师能帮我看看问题出现在哪儿了吗，谢谢了!

1. Sub 提取药品()
   
2.     Dim rng1 As Range, rng2 As Range, nr As Long, nc As Long
   
3.     Dim i, j, k, n
   
4.     Dim arr, brr, crr, drr
   
5.     On Error Resume Next
   
6.     Set rng1 = Application.InputBox("请选择需要提取的药品列", "选择", , , , , , 8)
   
7.     If rng1 Is Nothing Then Exit Sub
   
8.     On Error Resume Next
   
9.     Set rng2 = Application.InputBox("请选择全部药品列", "选择", , , , , , 8)
   
10.     If rng2 Is Nothing Then Exit Sub
    
11.     With Sheets(rng2.Parent.Name)
    
12.         nr = .Cells(Rows.Count, 1).End(xlUp).Row
    
13.         nc = .Cells(1, Columns.Count).End(xlToLeft).Column
    
14.         arr = .Range(.Cells(1, 1), .Cells(nr, nc))
    
15.         brr = rng1.Value
    
16.         crr = rng2.Value
    
17.         ReDim drr(1 To UBound(arr), 1 To UBound(arr, 2))
    
18.         n = 1
    
19.         For i = 2 To UBound(arr)
    
20.             For j = 1 To UBound(crr)
    
21.                 If brr(j, 1) = "" Then Exit For
    
22.                 If brr(j, 1) = crr(i, 1) Then
    
23.                     n = n + 1
    
24.                     For k = 1 To UBound(arr, 2)
    
25.                         drr(n, k) = arr(i, k)
    
26.                     Next
    
27.                     Exit For
    
28.                 End If
    
29.             Next
    
30.         Next
    
31.         For k = 1 To UBound(arr, 2)
    
32.             drr(1, k) = arr(1, k)
    
33.         Next
    
34.     End With
    
35.     With Sheets("模拟")
    
36.         .Cells.Clear
    
37.         .Range("a1").Resize(n, UBound(drr, 2)) = drr
    
38.         .Range("A1").CurrentRegion.Border.LineStyle = 1
    
39.         .Range("A1").CurrentRegion.EntireColumn.AutoFit
    
40.     End With
    
41. End Sub

复制代码

yjwdjfqb

xdragon 发表于 2014-10-9 21:05

• .Range("A1").CurrentRegion.Border.LineStyle = 1
• .Range("A1").CurrentRegion.EntireColumn.AutoFit
  

感谢老师了!
数据结果现在对了，但上面表格加边线，和自动列宽，我这儿没有起到作用呢。
没有达到加表线，和自动列宽的目的。