遍历单元格问题，耗时较长，能否简化

vba至于吗这么难

求助各位大神，这个目的是将sheet1里满足条件的单元格粘贴到sheet2，实际应用时一旦sheet1里非空单元格较多或参数调整不当就会导致需运行几十分钟才完成，看各位大神能否用数组或者其他说明方式帮我简化一下，感谢~~~我是新手....
另这段vba运行结果是没问题的，其中r，l，t等几个参数是要随时调整的，所以我单独列出来，显得很乱，另Cells(i - 1 + r, k + 101 + l))之类的也是我调整之后的表达方式，也比较乱，感谢大家~~

vba至于吗这么难

Sub scu()

Sheets("Sheet1").Select
Dim i, k, p, r, l, t As Long

r = 6

l = 6

t = 1

For k = 1 To 100
    For i = 18 To 160
            Sheets("Sheet1").Select
            p = Application.WorksheetFunction.CountA(Range(Cells(i, k), Cells(i - 1 + r, k - 1 + l)))
        If p <= t Then
        Sheets("Sheet1").Select
        Range(Cells(i, k + 102), Cells(i - 1 + r, k + 101 + l)).Copy Sheets("Sheet2").[C65500].End(xlUp).Offset(2)
        
        End If
    Next
Next


Beep

End Sub

vba至于吗这么难

vba至于吗这么难 发表于 2019-11-28 12:05
Sub scu()

Sheets("Sheet1").Select

原vba如上，看上去就不咋地...

vba至于吗这么难

求助求助

Jason_WangSS

你所说的满足条件 的 条件是什么
最好在数组操作，比较快

lsdongjh

1. Sub Test()
   
2.     Dim shSource As Worksheet, shResult As Worksheet
   
3.     Dim rgStart As Range, rgArea As Range, lngCurRowID As Long
   
4.     Dim lngResize_Row As Long, lngResize_Col As Long
   
5.     Dim lngOffSet_Row As Long, lngOffSet_Col As Long
   
6.     Dim lngCountMax As Long, lngGetOffSet As Long, lngTitleStep As String
   
7.    
   
8.     Set shSource = Sheets("Sheet1") '原数据表
   
9.     Set shResult = Sheets("Sheet2") '结果数据表
   
10.    
    
11.     lngResize_Row = 6 '判断区域的行数
    
12.     lngResize_Col = 6 '判断区域的列数
    
13.     lngCountMax = 1 '判断条件
    
14.     lngTitleStep = 2 '结果填充时，顶部的空行数
    
15.     lngCurRowID = shResult.Range("C" & Rows.Count).End(xlUp).Row + lngTitleStep '起始填充的行号
    
16.     lngGetOffSet = 102 '提取区域，与判断区域的 列 偏移数
    
17.    
    
18.     Set rgStart = shSource.Range("A18") '起始判断区域
    
19.     Application.ScreenUpdating = False
    
20.     Application.Cursor = xlWait
    
21.     For lngOffSet_Col = 0 To 99 '列偏移量，
    
22.         For lngOffSet_Row = 0 To 142 '行偏移量
    
23.             '判断区域=起始区域进行行、列偏移后，再扩展到相应的行、列数
    
24.             Set rgArea = rgStart.Offset(lngOffSet_Row, lngOffSet_Col).Resize(lngResize_Row, lngResize_Col)
    
25.             If Application.WorksheetFunction.CountA(rgArea) <= lngCountMax Then
    
26.                 rgArea.Offset(0, lngGetOffSet).Copy shResult.Range("C" & lngCurRowID)
    
27.                 '填充行号=起始填充行+判断区域的行数+顶部空行数
    
28.                 lngCurRowID = lngCurRowID + lngResize_Row + lngTitleStep
    
29.             End If
    
30.         Next
    
31.     Next
    
32.     Application.ScreenUpdating = True
    
33.     Application.Cursor = xlDefault
    
34.     MsgBox "OK"
    
35.    
    
36.     Beep
    
37. End Sub

复制代码

weiweiwhu

lsdongjh 发表于 2019-11-28 13:45

请问你这是在什么软件里写的代码？

vba至于吗这么难

lsdongjh 发表于 2019-11-28 13:45

相当快，1秒钟出结果~~~我之前真的用过1个多小时的....

lsdongjh

weiweiwhu 发表于 2019-11-28 14:02
请问你这是在什么软件里写的代码？

Excel 自带的VBE

vba至于吗这么难

lsdongjh 发表于 2019-11-28 14:58
Excel 自带的VBE

好用是很好用，但大神这是什么原理呢，求解啊，我看半天看不出来两者的差别何在，我就是一小白....