hiénlinh197
Thành viên tiêu biểu
- Tham gia
- 26/5/09
- Bài viết
- 491
- Được thích
- 113
Bạn chạy thử hàm này nhé.Nhờ các bạn viết giúp hàm như file đính kè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
=noikytu(3,";",B3:F10)
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 đỡChưa hiểu rõ, bạn thử hàm trong file này xem sao.
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?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)
Ban xem nhe.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!
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
=noikytu(3,";",TRUE,B3:F15)
Cảm ơn bạn @snow25Ban 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)
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é.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
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 @snow25Bạ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ọnBạ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
Em chào anh @HieuCD anh ơi công thức vẫn bị sai anh àNhiều lệnh giống nhau, rút code còn 1/2 cho gọn
Bạn chạy code này xem đúng không nhé.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!
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 đã đúngBạ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
Bạn cho cái ví dụ xem nào.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 xem giúp mình nhéBạn cho cái ví dụ xem nào.
Bạn chạy thêm cái này nhé.Bạn xem giúp mình nhé
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 ! @snow25Bạ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
Thử codeEm 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!
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
DIỄN ĐÀN GIẢI PHÁP EXCEL