为按钮求代码

地道战

一个按钮，想求一段代码，到多个工作表中取值。要求见附件。

lr116529111

用正则表达式，应该不难

地道战

lr116529111 发表于 2017-3-25 20:07
用正则表达式，应该不难

大神能说详细点吗？什么叫正则表达式？

lr116529111

地道战 发表于 2017-3-26 07:14
大神能说详细点吗？什么叫正则表达式？

说错了，应该是SQL

lsc900707

其它两个依样画葫芦就是：
Sub lsc()
Dim brr(1 To 2000, 1 To 5)
For Each sht In Worksheets(Array("一店", "二店"))
    arr = sht.[a1].CurrentRegion
    For i = 2 To UBound(arr)
        If arr(i, 4) = "农行" Then
            n = n + 1
            For j = 1 To UBound(arr, 2)
                brr(n, j) = arr(i, j)
            Next
        End If
    Next
Next
    If n = 0 Then
        MsgBox "没有找到有关信息。"
    Else
        With Sheets("农行记录")
            .Columns("B:C").NumberFormatLocal = "@"
            .[A2].Resize(n,UBound(arr,2)) = brr
        End With
    End If
End Sub

地道战

lsc900707 发表于 2017-3-26 12:44
其它两个依样画葫芦就是：
Sub lsc()
Dim brr(1 To 2000, 1 To 5)

十分感谢，由于我的VBA水平太菜，实在没有看懂，能帮我加上注释语句吗？我需要移植的我的工作表里面去，我的工作表远比示例复杂。

地道战

lsc900707 发表于 2017-3-26 12:44
其它两个依样画葫芦就是：
Sub lsc()
Dim brr(1 To 2000, 1 To 5)

另外，运行时提示“下标越界”

lsc900707

地道战 发表于 2017-3-27 19:47
另外，运行时提示“下标越界”

就是根据你的附件要求写的代码，如果实际数据不同，那请上传实际数据。

lsc900707

地道战 发表于 2017-3-27 19:47
另外，运行时提示“下标越界”

请检查你的工作表名是否与附件相符

lsc900707

根据楼主实际数据，代码修改如下：

1. Sub 提取农行数据()
   
2.     Dim brr(1 To 2000, 1 To 10)
   
3.     Application.ScreenUpdating = False
   
4.     [a2:j2000].ClearContents
   
5.     For Each sht In Worksheets(Array("办公人员TOP", "生产中心办-设备TOP", "仓库TOP", "品质TOP", "织造TOP", "染色TOP", "涂层TOP", "印花TOP"))
   
6.         arr = sht.[a1].CurrentRegion
   
7.         For i = 4 To UBound(arr) - 1
   
8.             If arr(i, 9) = "农行" Then
   
9.                 n = n + 1
   
10.                 brr(n, 1) = n: brr(n, 2) = arr(i, 2): brr(n, 3) = arr(i, 3): brr(n, 4) = arr(i, 4): brr(n, 5) = arr(i, 5)
    
11.                 brr(n, 6) = arr(i, 7): brr(n, 7) = arr(i, 8): brr(n, 8) = arr(i, 9): brr(n, 9) = arr(i, 24): brr(n, 10) = arr(i, 25)
    
12.             End If
    
13.         Next
    
14.     Next
    
15.     If n = 0 Then
    
16.         MsgBox "没有找到有关信息！"
    
17.     Else
    
18.         With Sheets("农行")
    
19.             .Columns("F:G").NumberFormatLocal = "@"
    
20.             .[a2].Resize(n, 10) = brr
    
21.         End With
    
22.     End If
    
23.     Application.ScreenUpdating = False
    
24. End Sub

复制代码