自定义函数--提取单元格内多个被分开的数字

YZC51

谢谢 Zamyi 老师！
http://club.excelhome.net/thread-1413612-1-1.html
Sub tq()'取得模块4 的全部代码
Dim m As Object, a
For Each m In ThisWorkbook.VBProject.VBComponents
  If m.Name = "模块4" Then
    a = Split(m.CodeModule.Lines(1, m.CodeModule.CountOfLines), Chr(10))
    [d1].Resize(UBound(a) + 1) = Application.Transpose(a)
  End If
Next
End Sub

WYS67

YZC51 发表于 2019-9-11 10:54
Function SHUZI(T) '提取单元格中的数字
    Dim i, str1
    For i = 1 To Len(T.Value)

恳请老师根据http://club.excelhome.net/thread-1498964-1-1.html里的运算规则，编写个自定义函数呗。

YZC51

谢谢老师！
http://club.excelhome.net/thread-18045-3-1.html

Function FindStr(strObj As String, strSou As String, strLen As Integer) As String
Dim i As Integer
For i = 1 To Len(strSou)
     FindStr = Mid(strSou, i, strLen)
         If FindStr Like strObj Then
           Exit Function
         End If
Next i
End Function

Sub 测试()
Dim s As String
s = "124ewgteerh124ewgterh 2003-02-03 wdqwfefwewg"
MsgBox FindStr("####-##-##", s, 10)
MsgBox FindStr(" ?*", s, 14)
End Sub

YZC51

谢谢老师！
http://club.excelhome.net/thread-18045-3-1.html
Function FindStrPro(strObj As String, strSou As String, strLen As Integer) As String
Dim s(3) As String
Dim l(3) As Integer
s(3) = "*" & strObj & "*"
    If strSou Like s(3) Then
        Do
            s(0) = strSou
            l(0) = Len(s(0))
            l(1) = Int(l(0) * 0.5 + 0.5)
            l(2) = l(0) - l(1)
               If l(2) > strLen Then
                     s(1) = Left(s(0), l(1))
                     s(2) = Right(s(0), l(2))
                          If s(1) Like s(3) Then
                               strSou = s(1)
                          ElseIf s(2) Like s(3) Then
                               strSou = s(2)
                          Else: strSou = Mid(s(0), l(1) - strLen + 1, strLen * 2 - 2)
                            Exit Do
                          End If
                Else
                             Exit Do
                End If
         Loop
         FindStrPro = FindStr(strObj, strSou, strLen)
         Else: FindStrPro = ""
         End If
End Function

Private Function FindStrPos(strObj As String, ByVal strSou As String, strLen As Integer) As Integer
  Dim s1 As String
  Dim s2 As String
  s1 = strSou
  s2 = FindStrPro(strObj, strSou, strLen)
   If s2 <> "" Then
     FindStrPos = InStr(s1, s2)
   Else
       FindStrPos = 0
   End If
End Function

summeren

YZC51 发表于 2019-8-2 09:01
http://club.excelhome.net/thread-1467934-1-1.html
38楼 ggmmlol 老师的代码。谢谢老师！
自定义的TEXT ...

您好 这个textjion可以帮忙看看 如何修改 多个分隔符可以使用？谢谢

YZC51

WYS67 发表于 2019-9-16 11:32
恳请老师根据http://club.excelhome.net/thread-1498964-1-1.html里的运算规则，编写个自定义函数呗。

谢谢老师信任！学生好的慢慢领会！

YZC51

summeren 发表于 2019-9-16 11:36
您好 这个textjion可以帮忙看看 如何修改 多个分隔符可以使用？谢谢

老师好！很抱歉对这个函数不甚了了!还请原作者修改比较好！

YZC51

Function FindStr(strObj As String, strSou As String, strLen As Integer) As String
Dim i As Integer’1、表达式支持通配符；2、原来字符串；3、需取字符数
For i = 1 To Len(strSou) + 1
    FindStr = Mid(strSou, i, strLen)
    If FindStr Like strObj Then Exit Function
Next i
End Function

YZC51

文件目录生成
http://club.excelhome.net/thread-1499349-1-1.html
文件目录自动生成-已修改1.rar (72.09 KB, 下载次数: 71)

2019-9-17 20:33 上传

点击文件名下载附件

YZC51

数据分类-折叠效果
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Interior.Color <> vbWhite Then
        If Target.Offset(1, 0).EntireRow.Hidden = False Then
            Target.CurrentRegion.Offset(1, 0).EntireRow.Hidden = True
            Target.Offset(1, 1).Select
        Else
            Target.CurrentRegion.Offset(1, 0).EntireRow.Hidden = False
             Target.Offset(1, 1).Select
        End If
    End If
End Sub