Xin hàm tìm chuỗi ký tự theo số lượng ký tự bằng VBA

snow25

Thành viên tích cực
Tham gia ngày
24 Tháng bảy 2018
Bài viết
1,498
Được thích
1,193
Điểm
210
Nhờ các bạn viết giúp hàm như file đính kèm
Bạn chạy thử hàm này nhé.
Mã:
Function noikytu(ByVal so As Integer, ByVal dauphancach As String, ParamArray mang()) As String
         Dim T, i As Long, j As Long, arr, s As String
         For Each T In mang
             arr = T.Value
             For j = 1 To UBound(arr, 2)
                 For i = UBound(arr, 1) - 1 To 1 Step -1
                     If Len(arr(i, j)) = so Then
                        If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                        Exit For
                     End If
                 Next i
            Next j
        Next
        noikytu = s
End Function
Mã:
=noikytu(3,";",B3:F10)
 

hiénlinh197

Thành viên tích cực
Tham gia ngày
26 Tháng năm 2009
Bài viết
481
Được thích
108
Điểm
395
Chưa hiểu rõ, bạn thử hàm trong file này xem sao.
Cảm ơn các bạn @snow25 ; @SA_DQ ; @Ba Tê và tất cả các bạn trên diễn đàn đã giúp đỡ
Công thức của các bạn rất chuẩn
Nhưng conng thức của bạn @snow25 là đạt nhất đạt được 3 tiêu chí
1-Tìm chuỗi có ký tự mong muốn và nối chúng lại với nhau
2-Tìm được trong phạm vi nhiều mảng
Một lần nữa xin trân thành cảm ơn các bạn!
Còn về lĩnh vực chuyên môn tôi không hiểu biết, nên không thể đánh giá bài của bạn nào là chuẩn nhất
 

hiénlinh197

Thành viên tích cực
Tham gia ngày
26 Tháng năm 2009
Bài viết
481
Được thích
108
Điểm
395
Bạn chạy thử hàm này nhé.
Mã:
Function noikytu(ByVal so As Integer, ByVal dauphancach As String, ParamArray mang()) As String
         Dim T, i As Long, j As Long, arr, s As String
         For Each T In mang
             arr = T.Value
             For j = 1 To UBound(arr, 2)
                 For i = UBound(arr, 1) - 1 To 1 Step -1
                     If Len(arr(i, j)) = so Then
                        If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                        Exit For
                     End If
                 Next i
            Next j
        Next
        noikytu = s
End Function
Mã:
=noikytu(3,";",B3:F10)
Cảm ơn bạn @snow25 bạn có thể thêm cho mình điều kiện nữa vào công thức được không?
Điều kiện là: Nếu các ký tự khác nhau thì lấy
=noikytu(3,";",B3:F10;"K")
Nếu thêm điều kiện "K" vào thì là lấy các ký tự khác nhau
Cảm ơn bạn rất nhiều!
 

snow25

Thành viên tích cực
Tham gia ngày
24 Tháng bảy 2018
Bài viết
1,498
Được thích
1,193
Điểm
210
Cảm ơn bạn @snow25 bạn có thể thêm cho mình điều kiện nữa vào công thức được không?
Điều kiện là: Nếu các ký tự khác nhau thì lấy
=noikytu(3,";",B3:F10;"K")
Nếu thêm điều kiện "K" vào thì là lấy các ký tự khác nhau
Cảm ơn bạn rất nhiều!
Ban xem nhe.
Mã:
Function noikytu(ByVal so As Integer, ByVal dauphancach As String, ByVal dk As Boolean, ParamArray mang()) As String
         Dim T, i As Long, j As Long, arr, s As String, K As Integer, dks As Boolean
    If dk = False Then
         For Each T In mang
             arr = T.Value
             For j = 1 To UBound(arr, 2)
                 For i = UBound(arr, 1) - 1 To 1 Step -1
                     If Len(arr(i, j)) = so Then
                        If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                        Exit For
                     End If
                 Next i
            Next j
       Next
    Else
       For Each T In mang
             arr = T.Value
             For j = 1 To UBound(arr, 2)
                 dks = False
                 For i = UBound(arr, 1) - 1 To 1 Step -1
                     If Len(arr(i, j)) = so Then
                        For K = 1 To so - 1
                            If Mid(arr(i, j), K, 1) <> Mid(arr(i, j), K + 1, 1) Then
                               dks = True
                               Exit For
                            End If
                        Next K
                        If dks = True Then
                            If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                            Exit For
                        End If
                    End If
                 Next i
            Next j
       Next
    End If
        noikytu = s
End Function
Mã:
=noikytu(3,";",TRUE,B3:F15)
 

hiénlinh197

Thành viên tích cực
Tham gia ngày
26 Tháng năm 2009
Bài viết
481
Được thích
108
Điểm
395
Ban xem nhe.
Mã:
Function noikytu(ByVal so As Integer, ByVal dauphancach As String, ByVal dk As Boolean, ParamArray mang()) As String
         Dim T, i As Long, j As Long, arr, s As String, K As Integer, dks As Boolean
    If dk = False Then
         For Each T In mang
             arr = T.Value
             For j = 1 To UBound(arr, 2)
                 For i = UBound(arr, 1) - 1 To 1 Step -1
                     If Len(arr(i, j)) = so Then
                        If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                        Exit For
                     End If
                 Next i
            Next j
       Next
    Else
       For Each T In mang
             arr = T.Value
             For j = 1 To UBound(arr, 2)
                 dks = False
                 For i = UBound(arr, 1) - 1 To 1 Step -1
                     If Len(arr(i, j)) = so Then
                        For K = 1 To so - 1
                            If Mid(arr(i, j), K, 1) <> Mid(arr(i, j), K + 1, 1) Then
                               dks = True
                               Exit For
                            End If
                        Next K
                        If dks = True Then
                            If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                            Exit For
                        End If
                    End If
                 Next i
            Next j
       Next
    End If
        noikytu = s
End Function
Mã:
=noikytu(3,";",TRUE,B3:F15)
Cảm ơn bạn @snow25
Công thức thật tuyệt vời
Cảm ơn bạn đã giúp đỡ

Chúc bạn ngủ ngon!
 

snow25

Thành viên tích cực
Tham gia ngày
24 Tháng bảy 2018
Bài viết
1,498
Được thích
1,193
Điểm
210
Nhờ bạn @snow25 xem và sửa giúp lại công thức, khi dữ liệu có mảng kết quả là 1 hoặc 2 dòng
Bạn xem lại nhé.Vì hôm trước code là có bỏ dòng cuối không tính nên nó bị vậy giờ tính cả dòng cuối nhé.
Mã:
Function noikytu(ByVal so As Integer, ByVal dauphancach As String, ByVal dk As Boolean, ParamArray mang()) As String
         Dim T, i As Long, j As Long, arr, s As String, K As Integer, dks As Boolean
    If dk = False Then
         For Each T In mang
             arr = T.Value
             For j = 1 To UBound(arr, 2)
                 For i = UBound(arr, 1) To 1 Step -1
                     If Len(arr(i, j)) = so Then
                        If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                        Exit For
                     End If
                 Next i
            Next j
       Next
    Else
       For Each T In mang
             arr = T.Value
             For j = 1 To UBound(arr, 2)
                 dks = False
                 For i = UBound(arr, 1) To 1 Step -1
                     If Len(arr(i, j)) = so Then
                        For K = 1 To so - 1
                            If Mid(arr(i, j), K, 1) <> Mid(arr(i, j), K + 1, 1) Then
                               dks = True
                               Exit For
                            End If
                        Next K
                        If dks = True Then
                            If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                            Exit For
                        End If
                    End If
                 Next i
            Next j
       Next
    End If
        noikytu = s
End Function
 

hiénlinh197

Thành viên tích cực
Tham gia ngày
26 Tháng năm 2009
Bài viết
481
Được thích
108
Điểm
395
Bạn xem lại nhé.Vì hôm trước code là có bỏ dòng cuối không tính nên nó bị vậy giờ tính cả dòng cuối nhé.
Mã:
Function noikytu(ByVal so As Integer, ByVal dauphancach As String, ByVal dk As Boolean, ParamArray mang()) As String
         Dim T, i As Long, j As Long, arr, s As String, K As Integer, dks As Boolean
    If dk = False Then
         For Each T In mang
             arr = T.Value
             For j = 1 To UBound(arr, 2)
                 For i = UBound(arr, 1) To 1 Step -1
                     If Len(arr(i, j)) = so Then
                        If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                        Exit For
                     End If
                 Next i
            Next j
       Next
    Else
       For Each T In mang
             arr = T.Value
             For j = 1 To UBound(arr, 2)
                 dks = False
                 For i = UBound(arr, 1) To 1 Step -1
                     If Len(arr(i, j)) = so Then
                        For K = 1 To so - 1
                            If Mid(arr(i, j), K, 1) <> Mid(arr(i, j), K + 1, 1) Then
                               dks = True
                               Exit For
                            End If
                        Next K
                        If dks = True Then
                            If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                            Exit For
                        End If
                    End If
                 Next i
            Next j
       Next
    End If
        noikytu = s
End Function
Cảm ơn bạn @snow25
Điều này do mình sơ xuất
Cảm ơn bạn nhiều nhé
Chúc bạn buổi tối vui nhé
 

HieuCD

Thành viên gạo cội
Tham gia ngày
14 Tháng chín 2010
Bài viết
5,333
Được thích
8,869
Điểm
560
Bạn xem lại nhé.Vì hôm trước code là có bỏ dòng cuối không tính nên nó bị vậy giờ tính cả dòng cuối nhé.
Mã:
Function noikytu(ByVal so As Integer, ByVal dauphancach As String, ByVal dk As Boolean, ParamArray mang()) As String
         Dim T, i As Long, j As Long, arr, s As String, K As Integer, dks As Boolean
    If dk = False Then
         For Each T In mang
             arr = T.Value
             For j = 1 To UBound(arr, 2)
                 For i = UBound(arr, 1) To 1 Step -1
                     If Len(arr(i, j)) = so Then
                        If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                        Exit For
                     End If
                 Next i
            Next j
       Next
    Else
       For Each T In mang
             arr = T.Value
             For j = 1 To UBound(arr, 2)
                 dks = False
                 For i = UBound(arr, 1) To 1 Step -1
                     If Len(arr(i, j)) = so Then
                        For K = 1 To so - 1
                            If Mid(arr(i, j), K, 1) <> Mid(arr(i, j), K + 1, 1) Then
                               dks = True
                               Exit For
                            End If
                        Next K
                        If dks = True Then
                            If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                            Exit For
                        End If
                    End If
                 Next i
            Next j
       Next
    End If
        noikytu = s
End Function
Nhiều lệnh giống nhau, rút code còn 1/2 cho gọn
 

hiénlinh197

Thành viên tích cực
Tham gia ngày
26 Tháng năm 2009
Bài viết
481
Được thích
108
Điểm
395

File đính kèm

snow25

Thành viên tích cực
Tham gia ngày
24 Tháng bảy 2018
Bài viết
1,498
Được thích
1,193
Điểm
210
Em chào anh @HieuCD anh ơi công thức vẫn bị sai anh à
Tức là kết quả vẫn có ký tự giống nhau
Anh xem và sửa giúp em với
Cảm ơn anh!
Bạn chạy code này xem đúng không nhé.
Mã:
Function noikytu(ByVal so As Integer, ByVal dauphancach As String, ByVal dk As Boolean, ParamArray mang()) As String
         Dim T, i As Long, j As Long, arr, s As String, K As Integer, dks As Boolean, tet As String
    If dk = False Then
         For Each T In mang
             arr = T.Value
             For j = 1 To UBound(arr, 2)
                 For i = UBound(arr, 1) To 1 Step -1
                     If Len(arr(i, j)) = so Then
                        If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                        Exit For
                     End If
                 Next i
            Next j
       Next
    Else
       For Each T In mang
             arr = T.Value
             For j = 1 To UBound(arr, 2)
                 For i = UBound(arr, 1) To 1 Step -1
                     dks = False
                     If Len(arr(i, j)) = so Then
                        For K = 1 To so - 1
                            tet = Mid(arr(i, j), K, 1)
                            If InStr(K + 1, arr(i, j), tet) Then
                               dks = True
                               Exit For
                            End If
                        Next K
                        If dks = False Then
                            If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                            Exit For
                        End If
                    End If
                 Next i
            Next j
       Next
    End If
        noikytu = s
End Function
 

hiénlinh197

Thành viên tích cực
Tham gia ngày
26 Tháng năm 2009
Bài viết
481
Được thích
108
Điểm
395
Bạn chạy code này xem đúng không nhé.
Mã:
Function noikytu(ByVal so As Integer, ByVal dauphancach As String, ByVal dk As Boolean, ParamArray mang()) As String
         Dim T, i As Long, j As Long, arr, s As String, K As Integer, dks As Boolean, tet As String
    If dk = False Then
         For Each T In mang
             arr = T.Value
             For j = 1 To UBound(arr, 2)
                 For i = UBound(arr, 1) To 1 Step -1
                     If Len(arr(i, j)) = so Then
                        If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                        Exit For
                     End If
                 Next i
            Next j
       Next
    Else
       For Each T In mang
             arr = T.Value
             For j = 1 To UBound(arr, 2)
                 For i = UBound(arr, 1) To 1 Step -1
                     dks = False
                     If Len(arr(i, j)) = so Then
                        For K = 1 To so - 1
                            tet = Mid(arr(i, j), K, 1)
                            If InStr(K + 1, arr(i, j), tet) Then
                               dks = True
                               Exit For
                            End If
                        Next K
                        If dks = False Then
                            If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                            Exit For
                        End If
                    End If
                 Next i
            Next j
       Next
    End If
        noikytu = s
End Function
Cảm ơn bạn @snow25 rất nhiều, công thức đã đúng
Nhưng có một chi tiết này nữa bạn xem giúp;
- Công thức bắt buộc phải chọn từ 2 ô trở lên thì mới có kết quả và khi chỉ chọn 1 ô thì bị lỗi
*Nhờ bạn chỉnh giúp là khi chọn 1 ô thì cũng có kết quả.
Cảm ơn bạn!
 

snow25

Thành viên tích cực
Tham gia ngày
24 Tháng bảy 2018
Bài viết
1,498
Được thích
1,193
Điểm
210
Cảm ơn bạn @snow25 rất nhiều, công thức đã đúng
Nhưng có một chi tiết này nữa bạn xem giúp;
- Công thức bắt buộc phải chọn từ 2 ô trở lên thì mới có kết quả và khi chỉ chọn 1 ô thì bị lỗi
*Nhờ bạn chỉnh giúp là khi chọn 1 ô thì cũng có kết quả.
Cảm ơn bạn!
Bạn cho cái ví dụ xem nào.
 

snow25

Thành viên tích cực
Tham gia ngày
24 Tháng bảy 2018
Bài viết
1,498
Được thích
1,193
Điểm
210
Bạn chạy thêm cái này nhé.
Mã:
Function noikytu3(ByVal so As Integer, ByVal dauphancach As String, ByVal dk As Boolean, ParamArray mang()) As String
         Dim T, i As Long, j As Long, arr, s As String, K As Integer, dks As Boolean, tet As String
    If dk = False Then
         For Each T In mang
             arr = laymang(T)
             For j = 1 To UBound(arr, 2)
                 For i = UBound(arr, 1) To 1 Step -1
                     If Len(arr(i, j)) = so Then
                        If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                        Exit For
                     End If
                 Next i
            Next j
       Next
    Else
       For Each T In mang
             arr = laymang(T)
             For j = 1 To UBound(arr, 2)
                 For i = UBound(arr, 1) To 1 Step -1
                     dks = False
                     If Len(arr(i, j)) = so Then
                        For K = 1 To so - 1
                            tet = Mid(arr(i, j), K, 1)
                            If InStr(K + 1, arr(i, j), tet) Then
                               dks = True
                               Exit For
                            End If
                        Next K
                        If dks = False Then
                            If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                            Exit For
                        End If
                    End If
                 Next i
            Next j
       Next
    End If
        noikytu3 = s
End Function
Function laymang(ByVal mang As Range)
      Dim arr()
      If mang.Count = 1 Then
         ReDim arr(1 To 1, 1 To 1): arr(1, 1) = mang.Value
      Else
         arr = mang.Value
      End If
      laymang = arr()
End Function
 

hiénlinh197

Thành viên tích cực
Tham gia ngày
26 Tháng năm 2009
Bài viết
481
Được thích
108
Điểm
395
Bạn chạy thêm cái này nhé.
Mã:
Function noikytu3(ByVal so As Integer, ByVal dauphancach As String, ByVal dk As Boolean, ParamArray mang()) As String
         Dim T, i As Long, j As Long, arr, s As String, K As Integer, dks As Boolean, tet As String
    If dk = False Then
         For Each T In mang
             arr = laymang(T)
             For j = 1 To UBound(arr, 2)
                 For i = UBound(arr, 1) To 1 Step -1
                     If Len(arr(i, j)) = so Then
                        If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                        Exit For
                     End If
                 Next i
            Next j
       Next
    Else
       For Each T In mang
             arr = laymang(T)
             For j = 1 To UBound(arr, 2)
                 For i = UBound(arr, 1) To 1 Step -1
                     dks = False
                     If Len(arr(i, j)) = so Then
                        For K = 1 To so - 1
                            tet = Mid(arr(i, j), K, 1)
                            If InStr(K + 1, arr(i, j), tet) Then
                               dks = True
                               Exit For
                            End If
                        Next K
                        If dks = False Then
                            If s = Empty Then s = arr(i, j) Else s = s & dauphancach & arr(i, j)
                            Exit For
                        End If
                    End If
                 Next i
            Next j
       Next
    End If
        noikytu3 = s
End Function
Function laymang(ByVal mang As Range)
      Dim arr()
      If mang.Count = 1 Then
         ReDim arr(1 To 1, 1 To 1): arr(1, 1) = mang.Value
      Else
         arr = mang.Value
      End If
      laymang = arr()
End Function
Chuẩn rồi bạn ! @snow25
Cảm ơn bạn rất nhiều
Chúc bạn luôn vui nhé!
 

HieuCD

Thành viên gạo cội
Tham gia ngày
14 Tháng chín 2010
Bài viết
5,333
Được thích
8,869
Điểm
560
Em chào anh @HieuCD anh ơi công thức vẫn bị sai anh à
Tức là kết quả vẫn có ký tự giống nhau
Anh xem và sửa giúp em với
Cảm ơn anh!
Thử code
Mã:
Function NoiKyTu(ByVal SoKyTu As Integer, ByVal Deli As String, ByVal dk As Boolean, ParamArray sRng()) As String
  Dim Rng, sArr, tmp, i As Long, j As Long, n As Long, Res As String
  For Each Rng In sRng
    sArr = Rng.Value
    If TypeName(sArr) <> "Variant()" Then
      ReDim sArr(1 To 1, 1 To 1)
      sArr(1, 1) = Rng.Value
    End If
    For j = 1 To UBound(sArr, 2)
      For i = UBound(sArr, 1) To 1 Step -1
        tmp = sArr(i, j)
        If Len(tmp) = SoKyTu Then
          If dk = False Then
            If Res = Empty Then Res = tmp Else Res = Res & Deli & tmp
            Exit For
          Else
            For n = 1 To SoKyTu - 1
              If InStr(n + 1, tmp, Mid(tmp, n, 1)) > 0 Then Exit For
            Next n
            If n = SoKyTu Then
              If Res = Empty Then Res = tmp Else Res = Res & Deli & tmp
              Exit For
            End If
          End If
        End If
      Next i
    Next j
  Next
  NoiKyTu = Res
End Function
 
Top