自动提取高中低风险区

李筱龙

笨鸟飞不高 发表于 2022-9-7 16:12

学习了，非常感谢！

李筱龙

wanghan519 发表于 2022-9-7 15:52
用一行式玩：
忘记去重：

虽然看不懂，还是非常感谢！学习了。

李筱龙

kevinchengcw 发表于 2022-9-7 15:05
据说这样不用审核

学习了，非常感谢！

李筱龙

grf1973 发表于 2022-9-7 16:05
还是有点规律可寻的

谢谢您的VBA，完全满足了我的需要，非常感谢，但还请教一下，我在您的VBA后面通过录制宏以及函数的方式，加了一个比对功能，将比对的结果输出到表2，运行都没有问题，但出现一个奇怪的情况，每次关闭后，那个按钮没有链接到我“提取”的VBA上，每次打开都是提示无法运行全国高中低风险区VBA比对.xlsm!Extract宏，重新指向到“提取”后，再次打开又是如此，不知道什么原因，请指点一下，谢谢！

usedrange

Sub tqsj()
    Dim arr, d, i%, j%, r%, s%, s0%, s1%, k, k1, brr, box
    Set d = CreateObject("Scripting.Dictionary")
    r = Range("a1048576").End(xlUp).Row
    arr = Range("a3:a" & r)
    s = 1: k = "": k1 = ""
    While s < r - 1
        If InStr(arr(s, 1), "中风险区(") > 0 Then
            s0 = s                                                              '获取中高风险区的分界行号
        ElseIf InStr(arr(s, 1), "低风险区(") > 0 Then
            s1 = s                                                              '获取中低风险区的分界行号
        End If
        s = s + 1
    Wend
    For i = 3 To UBound(arr)
        k2 = ""
        If InStr(arr(i, 1), ")个") > 0 Then
            If arr(i + 1, 1) = "" And arr(i - 1, 1) = "" Then k = Split(arr(i, 1), "(")(0) & "|"    '获取省、直辖市名称
            If arr(i + 1, 1) <> "" And arr(i - 1, 1) = "" Then k1 = Split(arr(i, 1), "(")(0)        '获取地级市区名称
        ElseIf arr(i - 1, 1) <> "" And arr(i, 1) <> "" Then
            k2 = "|" & Split(arr(i, 1), " ")(0)                                                     '获取县区名称
        End If
        If arr(i, 1) <> "" And k2 <> "" Then
            If i < s0 Then d(Split(arr(1, 1), "(")(0) & "|" & k & k1 & k2) = ""                 '高风险区数据加入字典
            If i < s1 And i > s0 Then d(Split(arr(s0, 1), "(")(0) & "|" & k & k1 & k2) = ""     '中风险区数据加入字典
            If i > s1 Then d(Split(arr(s1, 1), "(")(0) & "|" & k & k1 & k2) = ""                '低风险区数据加入字典
        End If
    Next i
    ReDim brr(0 To d.Count, 0 To 3)
    For i = 0 To d.Count - 1
        box = Split(d.keys()(i), "|")
        For j = 0 To UBound(box)
            brr(i, j) = box(j)
        Next j
    Next i
    [c2].Resize(UBound(brr), 4) = brr
    Application.DisplayAlerts = False
    For i = Range("c3").End(xlDown).Row To 2 Step -1
        If Cells(i, "c") = Cells(i - 1, "c") Then Range(Cells(i, "c"), Cells(i - 1, "c")).Merge         '合并单元格
    Next i
    Set d = Nothing
    Application.DisplayAlerts = True
End Sub

zxsea_7426

wanghan519 发表于 2022-9-8 06:00
请求分析不来，selenium粗暴一点：

python 学了两天就晒网到现在了，

gwjkkkkk

Yalishanda30 发表于 2022-9-7 13:01
以前弄过一个可实时更新的，格式跟楼主要求的有区别

学习了。。。

三分醉，七分醒

Sub 风险地区()
Dim reg As Object, endRag As Range, Rag As Range, Rages As Range, myRag As Range, arr(1 To 3)
Application.ScreenUpdating = False


Range("h:k").Delete
Set myRag = Range("h2")
myRag.Select
Range("h1").Resize(1, 4) = Array("风险等级", "省(自治区,直辖市)", "市", "县(市）、区、街道")
Set endRag = Range("a" & Rows.Count).End(xlUp)
Set Rages = Range("a3", endRag)
risk = "高风险区"
Set reg1 = CreateObject("VBScript.Regexp")
Set reg2 = CreateObject("VBScript.Regexp")
Set reg3 = CreateObject("VBScript.Regexp")
reg1.Pattern = "[\u4e00-\u9fa5]{1,3}省\(|[\u4e00-\u9fa5]{1,}自治区\(|天津市\(|北京市\(|重庆市\(|上海市\("
reg2.Pattern = ".+\(\d+\)"
reg3.Pattern = "[0-9]+"
For Each Rag In Rages
    If Rag.Value <> "" Then
        Set m = reg1.Execute(Rag.Value)
        If m.Count <> 0 Then
            s_name = Replace(m(0), "(", "")
        Else
            Set n = reg2.Execute(Rag.Value)
            If n.Count <> 0 Then
                Select Case Mid(n(0), 1, 4)
                    Case "高风险区"
                        risk = "高风险区"
                    Case "低风险区"
                        risk = "低风险区"
                    Case "中风险区"
                        risk = "中风险区"
                    Case Else
                        sh_name = Replace(Replace(n(0), "(", ""), ")", "")
                        Set Matches = reg3.Execute(sh_name)
                        sh_name = Replace(sh_name, Matches(0), "")
                End Select
               
            Else
                If s_name = "天津市" Then
                    sh_name = "天津市"
                End If
               
                If myRag.Offset(-1, 3).Value <> Split(Rag.Value, " ")(0) Then
                    If s <> risk Then
                        myRag = risk
                        Count = Count + 1
                        arr(Count) = myRag.Row
                        s = risk
                    End If
                    
                    myRag.Offset(0, 1) = s_name
                    myRag.Offset(0, 2) = sh_name
                    myRag.Offset(0, 3) = Split(Rag.Value, " ")(0)
                    Set myRag = myRag.Offset(1, 0)
                End If
               
            End If
        End If
    End If
Next


Range("h" & arr(1), "h" & arr(2) - 1).Merge
Range("h" & arr(2), "h" & arr(3) - 1).Merge
Range("h" & arr(3), "h" & myRag.Row - 1).Merge
Range("h:k").EntireColumn.AutoFit
Range("h1:k" & myRag.Row - 1).Borders.LineStyle = 1
Application.ScreenUpdating = True


End Sub

grf1973

李筱龙 发表于 2022-9-8 11:26
谢谢您的VBA，完全满足了我的需要，非常感谢，但还请教一下，我在您的VBA后面通过录制宏以及函数的方式， ...

因为你代码中就没有EXtract这个宏，而是挂到“提取”下了。
我根据你的录制宏改了一下，不要不停在工作表之间跳。

另外根据比对的原理自己用数组编了一个，供参考。

grf1973

写得比较烦，其实用公式+数据筛选也不错。但如果数据量大的话，大量公式自动运算会影响速度。