[已解决]求助 VBA代码提取日期

as0810114

用VBA代码提取日期，很简单的需求，具体需求在附件中有描述，麻烦老师编写代码，谢谢。

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-4-11 15:14

1. Sub 提取日期()
   
2.     Dim i As Long
   
3.     Dim lLastrow As Long
   
4.     Dim j As Long, arr
   
5.     Dim result(), lCount As Long
   
6.     Dim sht As Worksheet
   
7.     ReDim result(1 To 1)
   
8.     Worksheets("总表").Activate
   
9.     For Each sht In Worksheets
   
10.         If sht.Name <> "总表" Then
    
11.             With sht
    
12.             
    
13.                 lLastrow = .Cells(Rows.Count, "e").End(xlUp).Row
    
14.                 arr = .Range("d3:i" & lLastrow)
    
15.                 For j = LBound(arr) To UBound(arr)
    
16.                     If arr(j, 6) > 0 And Len(arr(j, 1)) > 0 Then
    
17.                         lCount = lCount + 1
    
18.                         ReDim Preserve result(1 To lCount)
    
19.                         result(lCount) = arr(j, 1)
    
20.                     End If
    
21.                 Next
    
22.             End With
    
23.         End If
    
24.     Next
    
25.     If lCount > 0 Then
    
26.         Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(lCount) = WorksheetFunction.Transpose(result)
    
27.     End If
    
28. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

B列效果不需要吧？

as0810114

hwc2ycy 发表于 2013-4-11 15:03
B列效果不需要吧？

不需要B列的，只需要日期。

lisachen

1. Sub test()
   
2.     Dim arr(1 To 1000, 1 To 2)
   
3.     For Each sh In Worksheets
   
4.         If sh.Name <> "总表" Then
   
5.             irow = sh.[h65536].End(xlUp).Row
   
6.             For x = 3 To irow
   
7.                 If sh.Cells(x, "i") <> 10 And sh.Cells(x, "i") <> 0 Then
   
8.                     k = k + 1
   
9.                     arr(k, 1) = sh.Cells(x, "d")
   
10.                     arr(k, 2) = sh.Name & "中满足条件返回值"
    
11.                 End If
    
12.             Next x
    
13.         End If
    
14.     Next
    
15.     With Sheets("总表")
    
16.         .Range("a2").Resize(k, 2) = arr
    
17.     End With
    
18. End Sub
    

复制代码

hwc2ycy

1. Sub 提取日期()
   
2.     Dim i As Long
   
3.     Dim lLastrow As Long
   
4.     Dim j As Long, arr
   
5.     Dim result(), lCount As Long
   
6.     Dim sht As Worksheet
   
7.     ReDim result(1 To 1)
   
8.     Worksheets("总表").Activate
   
9.     For Each sht In Worksheets
   
10.         If sht.Name <> "总表" Then
    
11.             With sht
    
12.             
    
13.                 lLastrow = .Cells(Rows.Count, "e").End(xlUp).Row
    
14.                 arr = .Range("d3:i" & lLastrow)
    
15.                 For j = LBound(arr) To UBound(arr)
    
16.                     If arr(j, 6) > 0 And Len(arr(j, 1)) > 0 Then
    
17.                         lCount = lCount + 1
    
18.                         ReDim Preserve result(1 To lCount)
    
19.                         result(lCount) = arr(j, 1)
    
20.                     End If
    
21.                 Next
    
22.             End With
    
23.         End If
    
24.     Next
    
25.     If lCount > 0 Then
    
26.         Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(lCount) = WorksheetFunction.Transpose(result)
    
27.     End If
    
28. End Sub

复制代码

wayy

hwc2ycy 发表于 2013-4-11 15:14

提取日期.rar (11.53 KB, 下载次数: 7)

2013-4-11 15:21 上传

点击文件名下载附件
没用数组，代码简单 ，数据量小可以。

jxncfxsf

弄了一个，你看行否

as0810114

hwc2ycy 发表于 2013-4-11 15:14

还需要改进一下，有的分表中 I 列值满足条件，但是该行D列的值为空，也需要提取出来。

hwc2ycy

1. Sub 提取日期()
   
2.     Dim i As Long
   
3.     Dim lLastrow As Long
   
4.     Dim j As Long, arr
   
5.     Dim result(), lCount As Long
   
6.     Dim sht As Worksheet
   
7.     ReDim result(1 To 1)
   
8.     Worksheets("总表").Activate
   
9.     For Each sht In Worksheets
   
10.         If sht.Name <> "总表" Then
    
11.             With sht
    
12.             
    
13.                 lLastrow = .Cells(Rows.Count, "e").End(xlUp).Row
    
14.                 arr = .Range("d3:i" & lLastrow)
    
15.                 For j = LBound(arr) To UBound(arr)
    
16.                     If arr(j, 6) > 0 Then
    
17.                         lCount = lCount + 1
    
18.                         ReDim Preserve result(1 To lCount)
    
19.                         result(lCount) = arr(j, 1)
    
20.                     End If
    
21.                 Next
    
22.             End With
    
23.         End If
    
24.     Next
    
25.     If lCount > 0 Then
    
26.         Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(lCount) = WorksheetFunction.Transpose(result)
    
27.     End If
    
28. End Sub

复制代码

你的效果里可没有把红的日期列显示啊。