请改公式为vba代码

lrh788

zhangzhang 发表于 2018-5-24 20:11
Public Sub test()
Dim Arr, Brr
Dim i As Long

谢谢，太好了，非常实用！

lrh788

=LEFT(MID(A2,MIN(FIND({"区","市","县"},A2&"区市县"))+1,20),MAX(IFERROR(FIND({"区","镇","村","办","道"},MID(A2,MIN(FIND({"区","市","县"},A2&"区市县"))+1,20)),)))
请各位老师帮忙把上面数组公式改写成代码！我的数据有70多万条，数组公式运行很慢！（附件中有两个公式，运行结果一样）

lrh788

请各位老师辛苦下帮我把22楼公式转换成vba代码？在此谢过！！！

lrh788

再次请各位大神帮忙写下的代码！在线急等！！

一把小刀闯天下

lrh788 发表于 2018-6-9 13:34
=LEFT(MID(A2,MIN(FIND({"区","市","县"},A2&"区市县"))+1,20),MAX(IFERROR(FIND({"区","镇","村","办","道 ...

'不会公式，找了些规律掰了一个，自己试一下看看

Option Explicit

Sub test()
  Dim mark, i, j, k, t, arr, pos
  t = Split("市 县 区,乡 镇 办 区 道 村", ",") '有先后次序
  ReDim mark(UBound(t))
  For i = 0 To UBound(mark): mark(i) = Split(t(i)): Next
  arr = Range("a2:a" & Cells(Rows.Count, "a").End(xlUp).Row)
  For i = 1 To UBound(arr, 1)
    For j = 0 To UBound(mark(0))
      If InStr(arr(i, 1), mark(0)(j)) Then Exit For
    Next
    If j < UBound(mark(0)) + 1 Then
      t = Right(arr(i, 1), Len(arr(i, 1)) - InStr(arr(i, 1), mark(0)(j)))
      pos = 0
      For j = 0 To UBound(mark(1))
        If InStr(t, mark(1)(j)) Then pos = j
      Next
      If pos > 0 Then t = Left(t, InStr(t, mark(1)(pos)))
      arr(i, 1) = t
    End If
  Next
  [g2].Resize(UBound(arr, 1)) = arr '输出g列，自己修改
End Sub

lrh788

一把小刀闯天下 发表于 2018-6-10 11:29
'不会公式，找了些规律掰了一个，自己试一下看看

Option Explicit

谢谢老师，代码已符合要求！