[已解决]用VBA 按要求复制数据到表2中

熊伟

需求：点周复制按扭，把判定是否延误中达成的所有数据复制到sheet2中

复制并粘贴.rar (10.11 KB, 下载次数: 3)

2015-3-30 18:31 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

26759761@qq.com

2015-3-30 19:56

1. Sub 按钮1_Click()
   
2. Dim ar, br(), x, l, r
   
3. ar = Range("a4").CurrentRegion
   
4. ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
   
5.   For x = 2 To UBound(ar)
   
6.     If Not Application.IsNA(ar(x, 8)) Then
   
7.        If ar(x, 8) = "达成" Then
   
8.           r = r + 1
   
9.           For l = 1 To UBound(ar, 2)
   
10.               br(r, l) = ar(x, l)
    
11.           Next
    
12.        End If
    
13.      End If
    
14.   Next
    
15.   Sheet2.Select: Rows("2:65500").Clear
    
16.   Range("a2").Resize(r, UBound(ar, 2)) = br
    
17.   MsgBox "汇总完毕"
    
18. End Sub
    

复制代码

跳转到最佳答案楼层

熊伟

求人指定
自己在百度找了几个不合我的要求！自己改不了！

26759761@qq.com

1. Sub 复制粘贴()
   
2. Dim ar, br(), x, l, r
   
3. ar = Range("a4").CurrentRegion
   
4. ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
   
5.   For x = 2 To UBound(ar)
   
6.     If ar(x, 8) = "达成" Then
   
7.       r = r + 1
   
8.       For l = 1 To UBound(ar, 2)
   
9.         br(r, l) = ar(x, l)
   
10.       Next
    
11.     End If
    
12.   Next
    
13.   Sheet2.Select: Rows("2:65500").Clear
    
14.   Range("a2").Resize(r, UBound(ar, 2)) = br
    
15.   MsgBox "汇总完毕"
    
16. End Sub
    

复制代码

熊伟

26759761@qq.com 发表于 2015-3-30 18:43

看了很多VBA代码，请问一般怎么学习呀，看你们好像非常熟练，一下子就写出来了，而我们这些菜鸟只能拿来用！

熊伟

26759761@qq.com 发表于 2015-3-30 18:43

再追问一个问题，如果刚达成这列是用公式算出来的，好像用这个VBA就不能成功了！

熊伟

复制并粘贴2.rar (18.38 KB, 下载次数: 3)

2015-3-30 19:21 上传

点击文件名下载附件 附件上传了

26759761@qq.com

1. Sub 按钮1_Click()
   
2. Dim ar, br(), x, l, r
   
3. ar = Range("a4").CurrentRegion
   
4. ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
   
5.   For x = 2 To UBound(ar)
   
6.     If Not Application.IsNA(ar(x, 8)) Then
   
7.        If ar(x, 8) = "达成" Then
   
8.           r = r + 1
   
9.           For l = 1 To UBound(ar, 2)
   
10.               br(r, l) = ar(x, l)
    
11.           Next
    
12.        End If
    
13.      End If
    
14.   Next
    
15.   Sheet2.Select: Rows("2:65500").Clear
    
16.   Range("a2").Resize(r, UBound(ar, 2)) = br
    
17.   MsgBox "汇总完毕"
    
18. End Sub
    

复制代码