[已解决]如何用数组等来改代码,提高运行速度

ls

想达到2个目的

1.如何将12个表的数据放入数组中,每个表 1-6列先放数组中 然后7-12放数组中,代码如何写

2.如何提高下面代码运算速度
查找区域用数组表示.rar (25.68 KB, 下载次数: 20)

2012-8-19 01:38 上传

点击文件名下载附件

只是做模糊查询,把查询到的,复制到最后一表中


Sub 提取部份()
    Dim s As String
    Dim k As Byte, j As Long, i As Long
    On Error Resume Next
    s = Application.InputBox("请输入查找内容", "查找")
    Application.ScreenUpdating = False
    Sheets(Sheets.Count).Rows("2:10000").ClearContents
    For k = 1 To Sheets.Count - 1
        Sheets(k).Select
        '    MsgBox Sheets(k).Name
        For j = 3 To 15 Step 6
            For i = 1 To Sheets(k).Cells(65536, j - 1).End(3).Row
                If Sheets(k).Cells(i, j) Like "*" & s & "*" Then
                    Sheets(k).Range(Cells(i, j - 2), Cells(i, j + 3)).Copy
                    Sheets(Sheets.Count).Cells(65536, 2).End(3).Offset(1, -1).PasteSpecial Paste:=xlPasteValues
                    Sheets(Sheets.Count).Columns("B:B").NumberFormatLocal = "yyyy-m-d"
                End If
            Next
        Next
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "数据已复制！"
    Sheets(Sheets.Count).Select
    Cells.Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
End Sub

最佳答案

月排行榜 / 总排行榜

柳如烟

2012-8-19 08:05

1. 
   
2. Sub 提取部份02()
   
3.     Dim s As String
   
4.     Dim k As Byte, j As Long, i As Long, c As Integer
   
5.     Dim a, arr()
   
6.     s = Application.InputBox("请输入查找内容", "查找")
   
7.     Application.ScreenUpdating = False
   
8.     For k = 1 To Sheets.Count - 1
   
9.         a = Sheets(k).Range("a5:l" & Sheets(k).UsedRange.Rows.Count)
   
10.         For i = 1 To UBound(a)
    
11.             If a(i, 3) Like "*" & s & "*" Then
    
12.                 j = j + 1
    
13.                 ReDim Preserve arr(1 To 6, 1 To j)
    
14.                 For c = 1 To 6
    
15.                     arr(c, j) = a(i, c)
    
16.                 Next
    
17.             End If
    
18.         Next
    
19.         For i = 1 To UBound(a)
    
20.             If a(i, 9) Like "*" & s & "*" Then
    
21.                 j = j + 1
    
22.                 ReDim Preserve arr(1 To 6, 1 To j)
    
23.                 For c = 1 To 6
    
24.                     arr(c, j) = a(i, c + 6)
    
25.                 Next
    
26.             End If
    
27.         Next
    
28.     Next
    
29.     With Sheets(Sheets.Count)
    
30.         .Rows("2:10000").ClearContents
    
31.         .Range("b:b").NumberFormatLocal = "yyyy-m-d"
    
32.         .Range("a2").Resize(j, 6) = Application.Transpose(arr)
    
33.         MsgBox "数据已复制！"
    
34.         .Select
    
35.     End With
    
36.     Application.ScreenUpdating = True
    
37. End Sub
    

复制代码

跳转到最佳答案楼层

qgs2012

我什么时候能够看懂上面的代码啊？好远。。。

柳如烟

1. 
   
2. Sub 提取部份02()
   
3.     Dim s As String
   
4.     Dim k As Byte, j As Long, i As Long, c As Integer
   
5.     Dim a, arr()
   
6.     s = Application.InputBox("请输入查找内容", "查找")
   
7.     Application.ScreenUpdating = False
   
8.     For k = 1 To Sheets.Count - 1
   
9.         a = Sheets(k).Range("a5:l" & Sheets(k).UsedRange.Rows.Count)
   
10.         For i = 1 To UBound(a)
    
11.             If a(i, 3) Like "*" & s & "*" Then
    
12.                 j = j + 1
    
13.                 ReDim Preserve arr(1 To 6, 1 To j)
    
14.                 For c = 1 To 6
    
15.                     arr(c, j) = a(i, c)
    
16.                 Next
    
17.             End If
    
18.         Next
    
19.         For i = 1 To UBound(a)
    
20.             If a(i, 9) Like "*" & s & "*" Then
    
21.                 j = j + 1
    
22.                 ReDim Preserve arr(1 To 6, 1 To j)
    
23.                 For c = 1 To 6
    
24.                     arr(c, j) = a(i, c + 6)
    
25.                 Next
    
26.             End If
    
27.         Next
    
28.     Next
    
29.     With Sheets(Sheets.Count)
    
30.         .Rows("2:10000").ClearContents
    
31.         .Range("b:b").NumberFormatLocal = "yyyy-m-d"
    
32.         .Range("a2").Resize(j, 6) = Application.Transpose(arr)
    
33.         MsgBox "数据已复制！"
    
34.         .Select
    
35.     End With
    
36.     Application.ScreenUpdating = True
    
37. End Sub
    

复制代码

上清宫主

美女真棒！
等看第一问了

qushui

宫主 美女的代码里就有第一问的解答  她是一个代码解决两个问题了  呵呵

zjdh

可以简化一下：

Sub 提取部份03()
    Dim s$, k%, j%, i&, c%, L%, a, arr()
    s = Application.InputBox("请输入查找内容", "查找")
    If s = False Then Exit Sub   '处理对话框取消
    Application.ScreenUpdating = False
    For k = 1 To Sheets.Count - 1
        a = Sheets(k).Range("a5:l" & Sheets(k).UsedRange.Rows.Count)
        For i = 1 To UBound(a)
            For L = 0 To 1
                If a(i, L * 6 + 3) Like "*" & s & "*" Then
                    j = j + 1
                    ReDim Preserve arr(1 To 6, 1 To j)
                    For c = 1 To 6
                        arr(c, j) = a(i, c + 6 * L)
                    Next
                End If
            Next L, i, k
    Rows("2:10000").ClearContents
    Range("b:b").NumberFormatLocal = "yyyy-m-d"
    Range("a2").Resize(j, 6) = Application.Transpose(arr)
    MsgBox "数据已复制！"
    Application.ScreenUpdating = True
End Sub

查找区域用数组表示.rar (19.28 KB, 下载次数: 8)

2012-8-20 07:34 上传

点击文件名下载附件

上清宫主

zjdh 发表于 2012-8-19 10:32
可以简化一下： Sub 提取部份03()
    Dim s$, k%, j%, i&, c%, L%, a, arr()
    s = Application.Input ...

还能再提速不
另：好象楼主想要的1-6在前7-12在后

柳如烟

上清宫主 发表于 2012-8-19 10:40
还能再提速不
另：好象楼主想要的1-6在前7-12在后

因为楼主要求1~6列在前，7~12列在后，所以只能多循环一次。

ls

柳如烟 发表于 2012-8-19 11:54
因为楼主要求1~6列在前，7~12列在后，所以只能多循环一次。

可以在一起     

只是做模糊查询,把查询到的,复制到最后一表中

柳如烟

ls 发表于 2012-8-19 13:59
可以在一起     

只是做模糊查询,把查询到的,复制到最后一表中

1. 
   
2. Sub 提取部份02()
   
3.     Dim s As String
   
4.     Dim k As Byte, j As Long, j1%, i As Long, c As Integer
   
5.     Dim a, arr()
   
6.     s = Application.InputBox("请输入查找内容", "查找")
   
7.     Application.ScreenUpdating = False
   
8.     For k = 1 To Sheets.Count - 1
   
9.         a = Sheets(k).Range("a5:l" & Sheets(k).UsedRange.Rows.Count)
   
10.         For i = 1 To UBound(a)
    
11.             If a(i, 3) Like "*" & s & "*" Then
    
12.                 j = j + 1
    
13.                 ReDim Preserve arr(1 To 12, 1 To j)
    
14.                 For c = 1 To 6
    
15.                     arr(c, j) = a(i, c)
    
16.                 Next
    
17.             End If            
    
18.             If a(i, 9) Like "*" & s & "*" Then
    
19.                 j1 = j1 + 1
    
20.                 ReDim Preserve arr(1 To 12, 1 To j1)
    
21.                 For c = 7 To 12
    
22.                     arr(c, j1) = a(i, c)
    
23.                 Next
    
24.             End If
    
25.         Next
    
26.     Next
    
27.     With Sheets(Sheets.Count)
    
28.         .Rows("2:10000").ClearContents
    
29.         .Range("b:b").NumberFormatLocal = "yyyy-m-d"
    
30.         .Range("a2").Resize(j, 12) = Application.Transpose(arr)
    
31.         MsgBox "数据已复制！"
    
32.         .Select
    
33.     End With
    
34.     Application.ScreenUpdating = True
    
35. End Sub
    

复制代码

结果并排放在了同一个表中