[已解决]跪求代码

jiangdong110

跪求代码：如果sheet1中第一列单元格中的日期等于H1，那么要将日期相同的这些行的数字从第二列开始复制到28列，顺序粘贴到sheet2中？

最佳答案

月排行榜 / 总排行榜

hylees

2012-3-23 16:26

1. Sub 提取()
   
2.     Dim arr, i%, j%, arr1(), k%
   
3.     With Sheets("sheet1")
   
4.         arr = .Range("a6").Resize(.[a65536].End(3).Row - 5, 28)
   
5.         For i = 1 To UBound(arr)
   
6.             If arr(i, 1) = .[h1] Then
   
7.                 k = k + 1
   
8.                 ReDim Preserve arr1(1 To 27, 1 To k)
   
9.                 For j = 1 To 27
   
10.                     arr1(j, k) = arr(i, j + 1)
    
11.                 Next j
    
12.             End If
    
13.         Next i
    
14.     End With
    
15.     Sheets("sheet2").Range("a6:aa65536").ClearContents
    
16.     Sheets("sheet2").Range("a6").Resize(k, 27) = Application.Transpose(arr1)
    
17. End Sub

复制代码

跳转到最佳答案楼层

hylees

1. Sub 提取()
   
2.     Dim arr, i%, j%, arr1(), k%
   
3.     With Sheets("sheet1")
   
4.         arr = .Range("a6").Resize(.[a65536].End(3).Row - 5, 28)
   
5.         For i = 1 To UBound(arr)
   
6.             If arr(i, 1) = .[h1] Then
   
7.                 k = k + 1
   
8.                 ReDim Preserve arr1(1 To 27, 1 To k)
   
9.                 For j = 1 To 27
   
10.                     arr1(j, k) = arr(i, j + 1)
    
11.                 Next j
    
12.             End If
    
13.         Next i
    
14.     End With
    
15.     Sheets("sheet2").Range("a6:aa65536").ClearContents
    
16.     Sheets("sheet2").Range("a6").Resize(k, 27) = Application.Transpose(arr1)
    
17. End Sub

复制代码

xpw6061

Book2.zip (59.01 KB, 下载次数: 1)

2012-3-23 16:47 上传

点击文件名下载附件