提取省份市区

嘎嘎东方大道

删除H列空格字符" ",提取H列数据对应C列（省份）和D列（市区）行，其中（玉树藏族自治州）需要提取到C列（省份），

liulang0808

Sub 按钮1_Click()
    r = Cells(Rows.Count, 8).End(3).Row
    arr = [a1].Resize(r, 8)
    With CreateObject("vbscript.regexp")
        .Global = True
        For j = 122 To UBound(arr)
            .Pattern = "[^一-龥]+"
            arr(j, 8) = .Replace(arr(j, 8), "")
            If InStr(arr(j, 8), "玉树藏族自治州") > 0 Then
                arr(j, 1) = "玉树藏族自治州"
                arr(j, 2) = "玉树藏族自治州"
            Else
                .Pattern = "^(.+?(省|自治区|市))(.+?(市|自治州|旗|地区|自治县|县))"
                If .test(arr(j, 8)) Then
                    Set m = .Execute(arr(j, 8))
                    arr(j, 1) = m(0).submatches(0)
                    arr(j, 2) = m(0).submatches(2)
                End If
            End If
        Next j
    End With
    [a1].Resize(r, 8) = arr
End Sub

liulang0808

新建 Microsoft Excel 工作表.zip (30.05 KB, 下载次数: 20)

2024-1-6 06:57 上传

点击文件名下载附件

嘎嘎东方大道

liulang0808 发表于 2024-1-6 06:57
Sub 按钮1_Click()
    r = Cells(Rows.Count, 8).End(3).Row
    arr = [a1].Resize(r, 8)

老师，我这个设置进去没任何反应是什么原因

liulang0808

嘎嘎东方大道 发表于 2024-1-6 21:54
老师，我这个设置进去没任何反应是什么原因

下载的附件，点击按钮没有任何提示吗？

嘎嘎东方大道

liulang0808 发表于 2024-1-6 22:02
下载的附件，点击按钮没有任何提示吗？

附件没有任何提示，清除AB列后也无法重新提取

liulang0808

嘎嘎东方大道 发表于 2024-1-6 22:06
附件没有任何提示，清除AB列后也无法重新提取

Sub 按钮1_Click()
    r = Cells(Rows.Count, 8).End(3).Row
    arr = [a1].Resize(r, 8)
    With CreateObject("vbscript.regexp")
        .Global = True
        For j = 2 To UBound(arr)
            .Pattern = "[^一-龥]+"
            arr(j, 8) = .Replace(arr(j, 8), "")
            If InStr(arr(j, 8), "玉树藏族自治州") > 0 Then
                arr(j, 1) = "玉树藏族自治州"
                arr(j, 2) = "玉树藏族自治州"
            Else
                .Pattern = "^(.+?(省|自治区|市))(.+?(市|自治州|旗|地区|自治县|县))"
                If .test(arr(j, 8)) Then
                    Set m = .Execute(arr(j, 8))
                    arr(j, 1) = m(0).submatches(0)
                    arr(j, 2) = m(0).submatches(2)
                End If
            End If
        Next j
    End With
    [a1].Resize(r, 8) = arr
End Sub

SY郑

你看是你要的吧？