[已解决]求助excel提取特殊内容的解决方式

335805371

A
执行日期5.1-10.25执行
执行日趋3.30-4.30执行
待航线走向批复后执行 执行日期7.1-8.31执行
或739/319/320执行；执行日期6.1-10.25执行，自审核通过后执行



类似于这样的文本，在B列提取出以下格式
开始日期和结束日期
2014-05-01  2014-10-25
2014-03-30  2014--4-30
2014-07-01  2014-08-31

最佳答案

月排行榜 / 总排行榜

suye1010

2014-6-5 16:38

修改了一下烟花同学的代码，现在可以满足条件了！
G20142.zip (525.08 KB, 下载次数: 17)

2014-6-5 23:09 上传

点击文件名下载附件

1. 
   
2. Sub 提取()
   
3.     Dim arr
   
4.     arr = Range("S1:T" & Sheets(1).UsedRange.Rows.Count)
   
5.     Dim i&, j&
   
6.     Dim objRegExp As Object, obj As Object
   
7.     Set objRegExp = CreateObject("VBScript.regExp")
   
8.     With objRegExp
   
9.         .Global = True
   
10.         .Pattern = "(\d{1,2}\.\d{1,2})\-(\d{1,2}\.\d{1,2})"
    
11.         For i = 1 To UBound(arr)
    
12.             arr(i, 2) = ""
    
13.             If .test(arr(i, 1)) Then
    
14.                 Set obj = .Execute(arr(i, 1))
    
15.                 For j = 0 To obj.Count - 1
    
16.                     arr(i, 2) = arr(i, 2) & " " & DateSerial(2014, Split(obj(j).submatches(0), ".")(0), Split(obj(j).submatches(0), ".")(1)) & " " & DateSerial(2014, Split(obj(j).submatches(1), ".")(0), Split(obj(j).submatches(1), ".")(1))
    
17.                 Next j
    
18.             End If
    
19.             arr(i, 2) = Mid(arr(i, 2), 2, 1000)
    
20.         Next
    
21.     End With
    
22.     Set objRegExp = Nothing
    
23.     Range("S1").Resize(UBound(arr), 2).Value = arr
    
24. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Sub demo()
   
2.     Dim arr
   
3.     arr = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
   
4.     Dim i&
   
5.     Dim objRegExp As Object, obj As Object
   
6.     Set objRegExp = CreateObject("VBScript.regExp")
   
7.     With objRegExp
   
8.         .Global = True
   
9.         .Pattern = "(\d{1,2}\.\d{1,2})\-(\d{1,2}\.\d{1,2})"
   
10.         For i = 1 To UBound(arr)
    
11.             If .test(arr(i, 1)) Then
    
12.                 Set obj = .Execute(arr(i, 1))
    
13.                 arr(i, 2) = Format(CDate(Replace(obj(0).submatches(1), ".", "/")), "yyyy-mm-dd") & " " & Format(CDate(Replace(obj(0).submatches(1), ".", "/")), "yyyy-mm-dd")
    
14.             End If
    
15.         Next
    
16.     End With
    
17.     Set objRegExp = Nothing
    
18.     Range("a1").Resize(UBound(arr), 2).Value = arr
    
19. End Sub

复制代码

hwc2ycy

提取年月日.rar (15.34 KB, 下载次数: 5)

2014-6-4 15:39 上传

点击文件名下载附件

csmctjg

1. 
   
2. Sub aa()
   
3.     Dim i%, arr
   
4.     arr = Range("A1:A" & Range("A" & Rows.Count).End(3).Row)
   
5.     For i = 1 To UBound(arr)
   
6.         arr(i, 1) = Format(Replace(Split(Split(arr(i, 1), "执行日期")(1), "-")(0), ".", "-"), "yyyy-mm-dd") & " " & Format(Replace(Split(Split(Split(arr(i, 1), "执行日期")(1), "-")(1), "执行")(0), ".", "-"), "yyyy-mm-dd")
   
7.     Next
   
8.     [B1].Resize(UBound(arr)) = arr
   
9. End Sub
   

复制代码

335805371

csmctjg 发表于 2014-6-4 15:48

如果每一列值不为空，并且都含有执行日期，用那个方法没问题，可是有的记录是空的，有的不含有执行日期就是不用过滤的数据，执行宏的时候会报错

335805371

hwc2ycy 发表于 2014-6-4 15:39

这个结果开始日期和结束日期是一样的

335805371

hwc2ycy 发表于 2014-6-5 11:21
你得把要求说明白，另外数据最好上传完整了，少量数据只会影响大家的判断。

文档FD19那一列是备注信息，这一列内容分以下三种情况：
（1）不含有执行日期的
（2）内容为空
（3）含有执行日期的
注：不含执行日期的和内容为空的不用管，只过滤含有执行日期的内容

注：文档中执行日期以月日形式表示：如 7.1-8.31 代表开始执行时间为：2014-07-01  结束时间为：2014-08-31
含有执行日期的字段分为以下几种形式：
   A:   待航线走向批复后执行 执行日期7.1-8.31执行
   B:   执行日期：07.01-10.28 待航线走向批复后执行 与CA3967代码共享
   C:  执行日期：02.30-04.30 & 09.01-10.23 待航线走向批复后执行 与CA3967代码共享
   D:  与MF4214 MU4837代码共享 执行日期3.30-5.8 6.16-10.25执行 或73G执行

   我想得到的结果是：
   2014-07-01 2014-08-31
   2014-07-01 2014-10-28
   2014-02-30 2014-04-30 2014-09-01 2014-10-23
   2014-03-30 2014-05-08 2014-06-16 2014-10-25

suye1010

修改了一下烟花同学的代码，现在可以满足条件了！
G20142.zip (525.08 KB, 下载次数: 17)

2014-6-5 23:09 上传

点击文件名下载附件

1. 
   
2. Sub 提取()
   
3.     Dim arr
   
4.     arr = Range("S1:T" & Sheets(1).UsedRange.Rows.Count)
   
5.     Dim i&, j&
   
6.     Dim objRegExp As Object, obj As Object
   
7.     Set objRegExp = CreateObject("VBScript.regExp")
   
8.     With objRegExp
   
9.         .Global = True
   
10.         .Pattern = "(\d{1,2}\.\d{1,2})\-(\d{1,2}\.\d{1,2})"
    
11.         For i = 1 To UBound(arr)
    
12.             arr(i, 2) = ""
    
13.             If .test(arr(i, 1)) Then
    
14.                 Set obj = .Execute(arr(i, 1))
    
15.                 For j = 0 To obj.Count - 1
    
16.                     arr(i, 2) = arr(i, 2) & " " & DateSerial(2014, Split(obj(j).submatches(0), ".")(0), Split(obj(j).submatches(0), ".")(1)) & " " & DateSerial(2014, Split(obj(j).submatches(1), ".")(0), Split(obj(j).submatches(1), ".")(1))
    
17.                 Next j
    
18.             End If
    
19.             arr(i, 2) = Mid(arr(i, 2), 2, 1000)
    
20.         Next
    
21.     End With
    
22.     Set objRegExp = Nothing
    
23.     Range("S1").Resize(UBound(arr), 2).Value = arr
    
24. End Sub
    

复制代码