提取文号中的年份

AFree123

duquancai 发表于 2018-7-24 18:47
写个VBA函数，你看可以不？？？

谢谢老师！高手啊！好好用！

就是数据很多，要是能弄一个一键提取那就更方便了。

麻烦老师有空再看看，谢谢！

一把小刀闯天下

AFree123 发表于 2018-7-24 17:18
谢谢老师的帮助！
在实际工作中使用，会提示：下标越界
可能是由于数据不规范

Option Explicit

Sub test()
  Dim arr, i, j, mark
  On Error GoTo errmsg
  mark = Split("【,】,（,）,(,),〔,〕", ",") '要成对，中间加逗号（根据错误行提示进行添加）
  arr = Range("e3:e" & Cells(Rows.Count, "e").End(xlUp).Row)
  ReDim brr(1 To UBound(arr, 1), 1 To 1)
  For i = 1 To UBound(arr, 1)
    If InStr(arr(i, 1), "藏") Then
      For j = 0 To UBound(mark)
        arr(i, 1) = Replace(arr(i, 1), mark(j), IIf(j Mod 2 = 0, "[", "]"))
      Next
      brr(i, 1) = Split(Split(arr(i, 1), "[")(1), "]")(0)
    End If
  Next
  [g3].Resize(UBound(brr, 1)) = brr
Exit Sub
errmsg:
  MsgBox "检查行：" & i + 2
End Sub

AFree123

一把小刀闯天下 发表于 2018-7-24 19:32
Option Explicit

Sub test()

谢谢老师的帮助！
真的，很好用！增加提示与说明，方便了使用者据实修正VBA，具有扩展性！

AFree123

一把小刀闯天下 发表于 2018-7-24 19:32
Option Explicit

Sub test()

很抱歉，今天的鲜花用完了，明天补上！

小花鹿

用得着这么麻烦吗，直接从F列取不就行了？
Sub text()
Dim i&
For i = 3 To 20
    If Left(Cells(i, "e"), 1) = "藏" Then
        Cells(i, "g") = Year(Cells(i, "f"))
    End If
Next i
End Sub

YZC51

学习老师们的代码。谢谢！
Function 提取年份(x)
    On Error Resume Next
    With CreateObject("vbscript.regexp")
        .Pattern = "^藏.*?(\d{4})"
        提取年份 = Right(.Execute(x)(0), 4): If 提取年份 = 0 Then 提取年份 = ""
    End With
End Function

AFree123

小花鹿 发表于 2018-7-24 20:35
用得着这么麻烦吗，直接从F列取不就行了？
Sub text()
Dim i&

谢谢老师的关注
主要是我没说清楚，F列原有其他数据，现有的数据是我模拟的结果

AFree123

YZC51 发表于 2018-7-24 21:02
学习老师们的代码。谢谢！
Function 提取年份(x)
    On Error Resume Next

谢谢老师！
昨天送完的鲜花
今晚捧上鲜花

jy03342543

Sub 提取年份()
Dim Regx, Rn, Mat, M As Object
Dim Rng As Range
Dim I As Integer
Set Regx = CreateObject("vbscript.regexp")
Set Rng = Range("E3:E" & Cells(Rows.Count, "E").End(xlUp).Row)
With Regx
   For Each Rn In Rng
     .Global = True
     .Pattern = "(藏注会协?).([0-9]{4})."
        Set Mat = .Execute(Rn.Value)
          If .Test(Rn) Then
            Cells(I + 3, 7) = Mat(0).submatches(1)
          Else
            Cells(I + 3, 7) = ""
          End If
        I = I + 1
   Next Rn
End With
End Sub

AFree123

jy03342543 发表于 2018-7-25 09:13
Sub 提取年份()
Dim Regx, Rn, Mat, M As Object
Dim Rng As Range

谢谢老师的帮助