[已解决]谁能帮我设置一个宏？

ly5403119

8月份.rar (34.97 KB, 下载次数: 3)

2011-8-13 11:08 上传

点击文件名下载附件 在1日工作表中筛选出D列不为空、Z列为空的数据复制C-AA、AU、AV列到2日工作表中从C7按顺序排列（AB-AQ间有公式）。工作表密码123

最佳答案

月排行榜 / 总排行榜

fjmxwrs

2011-8-13 11:38

1. Sub aa()
   
2.     Dim arr, arr1(), i&, j&, y&, r&, x&, arr2, arr3()
   
3.     With Sheets("1日")
   
4.         r = .Range("B65536").End(xlUp).Row
   
5.         arr = .Range("C7:AA" & r).Value
   
6.         arr2 = .Range("AU7:AV" & r).Value
   
7.     End With
   
8.     For x = 1 To UBound(arr)
   
9.         If arr(x, 2) <> "" And arr(x, 24) = "" Then
   
10.             i = i + 1
    
11.             ReDim Preserve arr1(1 To UBound(arr, 2), 1 To i)
    
12.             ReDim Preserve arr3(1 To 2, 1 To i)
    
13.             For y = 1 To UBound(arr, 2)
    
14.                 arr1(y, i) = arr(x, y)
    
15.             Next y
    
16.             For j = 1 To 2
    
17.                 arr3(j, i) = arr2(x, j)
    
18.             Next j
    
19.         End If
    
20.     Next x
    
21.     With Sheets("2日")
    
22.         .Range("C7").Resize(UBound(arr1, 2), UBound(arr1)) = Application.Transpose(arr1)
    
23.         .Range("AU7").Resize(UBound(arr3, 2), UBound(arr3)) = Application.Transpose(arr3)
    
24.     End With
    
25. End Sub
    

复制代码

运行此宏即得
8月份.rar (47.12 KB, 下载次数: 20)

2011-8-13 11:40 上传

点击文件名下载附件

跳转到最佳答案楼层

fjmxwrs

1. Sub aa()
   
2.     Dim arr, arr1(), i&, j&, y&, r&, x&, arr2, arr3()
   
3.     With Sheets("1日")
   
4.         r = .Range("B65536").End(xlUp).Row
   
5.         arr = .Range("C7:AA" & r).Value
   
6.         arr2 = .Range("AU7:AV" & r).Value
   
7.     End With
   
8.     For x = 1 To UBound(arr)
   
9.         If arr(x, 2) <> "" And arr(x, 24) = "" Then
   
10.             i = i + 1
    
11.             ReDim Preserve arr1(1 To UBound(arr, 2), 1 To i)
    
12.             ReDim Preserve arr3(1 To 2, 1 To i)
    
13.             For y = 1 To UBound(arr, 2)
    
14.                 arr1(y, i) = arr(x, y)
    
15.             Next y
    
16.             For j = 1 To 2
    
17.                 arr3(j, i) = arr2(x, j)
    
18.             Next j
    
19.         End If
    
20.     Next x
    
21.     With Sheets("2日")
    
22.         .Range("C7").Resize(UBound(arr1, 2), UBound(arr1)) = Application.Transpose(arr1)
    
23.         .Range("AU7").Resize(UBound(arr3, 2), UBound(arr3)) = Application.Transpose(arr3)
    
24.     End With
    
25. End Sub
    

复制代码

运行此宏即得
8月份.rar (47.12 KB, 下载次数: 20)

2011-8-13 11:40 上传

点击文件名下载附件

ly5403119

要是加上复制到2日工作的中的数据改为红色怎么办？