求助：日期拆分并统一日期格式

maihh2001

EXCEL文件中，B列为日期列，但部分行的B列出现出类似合并格式，如“9月19、26日、10月10日”，“12月12、17、19日”和“9月21日、11月23日”格式，现需要拆分单独行，如果B列出现"9月19、26日、10月10日”，“12月12、17、19日”和“9月21日、11月23日”等类似格式，则在下方插入行，拆分B列内容为每一天，其他列内容不变，B列要求的格式是“YYYY-MM-DD”,使用VBA生成在另一工作表。

ynzsvt

请测试代码

sunya_0529

WPS里的JSA练习一下——

limonet

关键字：iif

limonet

Sub limonet()
    Dim Arr As Variant, Brr(1 To 999, 1 To 3) As Variant, h%, i%, j%, ArrTmp As Variant
    Arr = Range("A2:C9")
    For i = 1 To UBound(Arr)
        h = h + 1
        If Not IsDate(Arr(i, 2)) Then
            ArrTmp = Split(Arr(i, 2), "、")
            For j = 0 To UBound(ArrTmp)
                Brr(h + j, 1) = Arr(i, 1): Brr(h + j, 3) = Arr(i, 3)
                If ArrTmp(j) Like "*月*" Then
                    Brr(h + j, 2) = CDate("2024年" & IIf(ArrTmp(j) Like "*日", ArrTmp(j), ArrTmp(j) & "日"))
                Else
                    Brr(h + j, 2) = CDate("2024年" & Left(Arr(i, 2), InStr(Arr(i, 2), "月")) & IIf(ArrTmp(j) Like "*日", ArrTmp(j), ArrTmp(j) & "日"))
                End If
            Next j
            h = h + j - 1
        Else
            Brr(h, 1) = Arr(i, 1): Brr(h, 2) = Arr(i, 2): Brr(h, 3) = Arr(i, 3)
        End If
    Next i
    Range("H2").Resize(h, 3) = Brr
End Sub

limonet

Sub limonet()
    Dim Arr As Variant, Brr(1 To 999, 1 To 3) As Variant, h%, i%, j%, ArrTmp As Variant
    Arr = Range("A2:C9")
    For i = 1 To UBound(Arr)
        h = h + 1
        If Not IsDate(Arr(i, 2)) Then
            ArrTmp = Split(Arr(i, 2), "、")
            For j = 0 To UBound(ArrTmp)
                Brr(h + j, 1) = Arr(i, 1): Brr(h + j, 3) = Arr(i, 3)
                If ArrTmp(j) Like "*月*" Then
                    Brr(h + j, 2) = CDate("2024年" & ArrTmp(j) & IIf(ArrTmp(j) Like "*日", Null, "日"))
                Else
                    Brr(h + j, 2) = CDate("2024年" & Left(Arr(i, 2), InStr(Arr(i, 2), "月")) & ArrTmp(j) & IIf(ArrTmp(j) Like "*日", Null, "日"))
                End If
            Next j
            h = h + j - 1
        Else
            Brr(h, 1) = Arr(i, 1): Brr(h, 2) = Arr(i, 2): Brr(h, 3) = Arr(i, 3)
        End If
    Next i
    Range("H2").Resize(h, 3) = Brr
End Sub

醉眼看尘世

1. Sub test()
   
2. Dim reGxp1 As Object, reGxp2 As Object, Arr, i&, j&, tmPobj As Object, jL&, tmPstr$, Trr, Mstr$
   
3. Dim mRow&, Brr(1 To 100000, 1 To 3)
   
4. On Error Resume Next
   
5. Arr = Sheet1.[a1].CurrentRegion
   
6. Set reGxp1 = CreateObject("vbScript.regExp")
   
7. reGxp1.Global = True
   
8. reGxp1.Pattern = "(\d+)月(\d+)日"
   
9. Set reGxp2 = CreateObject("vbScript.regExp")
   
10. reGxp2.Global = True
    
11. reGxp2.Pattern = "(\d+)月((\d+)(、(\d+))*)"
    
12. jL = 0
    
13. For i = 2 To UBound(Arr, 1)
    
14.     If IsDate(Arr(i, 2)) Then
    
15.         jL = jL + 1
    
16.         For j = 1 To 3
    
17.             Brr(jL, j) = Arr(i, j)
    
18.         Next j
    
19.     Else
    
20.         If reGxp1.test(Arr(i, 2)) Then
    
21.             Set tmPobj = reGxp1.Execute(Arr(i, 2))
    
22.             For Each m In tmPobj
    
23.                 jL = jL + 1
    
24.                 Brr(jL, 1) = Arr(i, 1): Brr(jL, 3) = Arr(i, 3)
    
25.                 Brr(jL, 2) = DateValue(2024 & "-" & m.submatches(0) & "-" & m.submatches(1))
    
26.             Next m
    
27.             Arr(i, 2) = reGxp1.Replace(Arr(i, 2), "")
    
28.         End If
    
29.         If reGxp2.test(Arr(i, 2)) Then
    
30.             Set tmPobj = reGxp2.Execute(Arr(i, 2))
    
31.             For Each m In tmPobj
    
32.                 Mstr = m.submatches(0)
    
33.                 tmPstr = m.submatches(1)
    
34.                 Trr = Split(tmPstr, "、")
    
35.                 For k = 0 To UBound(Trr)
    
36.                     If IsNumeric(Trr(k)) Then
    
37.                         jL = jL + 1
    
38.                         Brr(jL, 1) = Arr(i, 1): Brr(jL, 3) = Arr(i, 3)
    
39.                         Brr(jL, 2) = DateValue(2024 & "-" & Mstr & "-" & Trr(k))
    
40.                     End If
    
41.                 Next k
    
42.             Next m
    
43.         End If
    
44.     End If
    
45. Next i
    
46. With Sheet1
    
47.     .Range("F:H").ClearFormats
    
48.     .[f1:h1] = Arr
    
49.     .[g2].Resize(jL, 1).NumberFormatLocal = "yyyy-mm-dd"
    
50.     .[f2].Resize(jL, 3) = Brr
    
51. End With
    
52. End Sub
    

复制代码

maihh2001

ynzsvt 发表于 2024-8-12 17:52
请测试代码

这个好象跟我的要求不一样哦

ynzsvt

maihh2001 发表于 2024-8-13 09:54
这个好象跟我的要求不一样哦

好吧，看来色才是您的需求。

usedrange

参与一下

1. Sub tt()
   
2.     Dim ar, br, m%, i%, j%, r%, t, s
   
3.     ar = Sheet1.[a1].CurrentRegion
   
4.     ReDim br(1 To 100, 1 To 3)
   
5.     r = 1
   
6.     For i = 1 To UBound(ar)
   
7.         If InStr(ar(i, 2), "、") > 0 Then
   
8.             t = Split(ar(i, 2), "、")
   
9.             For m = 0 To UBound(t)
   
10.                 If InStr(t(m), "月") > 0 Then
    
11.                     s = Split(t(m), "月")(0)
    
12.                     If InStr(t(m), "日") = 0 Then t(m) = t(m) & "日"
    
13.                 ElseIf InStr(t(m), "日") = 0 Then
    
14.                     t(m) = s & "月" & t(m) & "日"
    
15.                 ElseIf InStr(t(m), "日") > 0 Then
    
16.                     t(m) = s & "月" & t(m)
    
17.                 End If
    
18.                 br(r, 1) = ar(i, 1)
    
19.                 br(r, 2) = Format(t(m), "yyyy/mm/dd")
    
20.                 br(r, 3) = ar(i, 3)
    
21.                 r = r + 1
    
22.             Next m
    
23.         Else
    
24.             For j = 1 To UBound(ar, 2)
    
25.                 br(r, j) = ar(i, j)
    
26.             Next j
    
27.             r = r + 1
    
28.         End If
    
29.     Next i
    
30.     Sheet1.[f18].Resize(UBound(br), 3) = br
    
31. End Sub
    

复制代码