Đây nhé bạn xem.Nhờ các bạn trên diễn đàn viết giúp hàm như file đính kèm
Function chuyendulieu(ByVal mang As Range, ByVal dk As Boolean)
Dim arr, arr1, i As Long, j As Long
arr = mang.Value
ReDim arr1(1 To UBound(arr, 1) * UBound(arr, 2))
For i = 1 To UBound(arr, 1)
For j = 1 To UBound(arr, 2)
If Len(arr(i, j)) > 0 Then
a = a + 1
arr1(a) = arr(i, j)
End If
Next j
Next i
If dk = True Then
chuyendulieu = arr1
Else
chuyendulieu = Application.Transpose(arr1)
End If
End Function
Cảm ơn bạn @snow25 bạn ơi công thức vẫn bị lỗi khi trong mảng có lỗi vậy nhờ bạn sửa giúp như sauĐây nhé bạn xem.
Mã:Function chuyendulieu(ByVal mang As Range, ByVal dk As Boolean) Dim arr, arr1, i As Long, j As Long arr = mang.Value ReDim arr1(1 To UBound(arr, 1) * UBound(arr, 2)) For i = 1 To UBound(arr, 1) For j = 1 To UBound(arr, 2) If Len(arr(i, j)) > 0 Then a = a + 1 arr1(a) = arr(i, j) End If Next j Next i If dk = True Then chuyendulieu = arr1 Else chuyendulieu = Application.Transpose(arr1) End If End Function
Bạn chạy thử cái này xem.Cảm ơn bạn @snow25 bạn ơi công thức vẫn bị lỗi khi trong mảng có lỗi vậy nhờ bạn sửa giúp như sau
- Lấy thêm nhiều mảng
- Khi không có dữ liệu thì ="khong" (Hiện tại bây giờ là công thức trả về số "0"
- Khi trong mảng có các lỗi Value; Div; Name thì hàm không hoạt đống
Bạn xem và sửa giúp mình nhé
Cảm ơn bạn!
Function chuyendulieu(ByVal dk As Boolean, ParamArray mang())
Dim arr(1 To 1000), T, T1, a As Long
For Each T In mang
For Each T1 In T
If InStr(T1.Text, "#") = 0 Then
If Len(T1.Value) > 0 Then
a = a + 1
arr(a) = T1.Value
End If
End If
Next
Next
If dk = True Then
chuyendulieu.Resize(a) = arr
Else
chuyendulieu = Application.Transpose(arr)
End If
End Function
=chuyendulieu(FALSE,C2:E6)
Cảm ơn bạnBạn chạy thử cái này xem.
Mã:Function chuyendulieu(ByVal dk As Boolean, ParamArray mang()) Dim arr(1 To 1000), T, T1, a As Long For Each T In mang For Each T1 In T If InStr(T1.Text, "#") = 0 Then If Len(T1.Value) > 0 Then a = a + 1 arr(a) = T1.Value End If End If Next Next If dk = True Then chuyendulieu.Resize(a) = arr Else chuyendulieu = Application.Transpose(arr) End If End Function
Mã:=chuyendulieu(FALSE,C2:E6)
Bạn sửa theo code này nhé.Nhưng phần này vẫn bị lỗi bạn @snow25 ơi
Function chuyendulieu(ByVal dk As Boolean, ParamArray mang())
Dim arr(1 To 1000), T, T1, a As Long
For Each T In mang
For Each T1 In T
If InStr(T1.Text, "#") = 0 Then
If Len(T1.Value) > 0 Then
a = a + 1
arr(a) = T1.Value
End If
End If
Next
Next
If dk = True Then
chuyendulieu = arr
Else
chuyendulieu = Application.Transpose(arr)
End If
End Function
Sửa code của snow25 một chút được không nhé:Bạn sửa theo code này nhé.
Function chuyendulieu(ByVal dk As Boolean, Numb As Integer, ParamArray mang())
Dim arr(1 To 1000), T, T1, a As Long
For Each T In mang
For Each T1 In T
If InStr(T1.Text, "#") = 0 Then
If Len(T1.Value) > 0 Then
a = a + 1
arr(a) = T1.Value
End If
End If
Next
Next
If dk = True Then
chuyendulieu = arr(Numb)
Else
chuyendulieu = Application.Transpose(arr(Numb))
End If
End Function
Cảm ơn bạn @snow25Bạn sửa theo code này nhé.
Mã:Function chuyendulieu(ByVal dk As Boolean, ParamArray mang()) Dim arr(1 To 1000), T, T1, a As Long For Each T In mang For Each T1 In T If InStr(T1.Text, "#") = 0 Then If Len(T1.Value) > 0 Then a = a + 1 arr(a) = T1.Value End If End If Next Next If dk = True Then chuyendulieu = arr Else chuyendulieu = Application.Transpose(arr) End If End Function
Cảm ơn bạn @Sửa code của snow25 một chút được không nhé:
Sử dụng công thức để kéo theo dòng: =chuyendulieu(TRUE,ROW($A1),$C$2:$E$6)Mã:Function chuyendulieu(ByVal dk As Boolean, Numb As Integer, ParamArray mang()) Dim arr(1 To 1000), T, T1, a As Long For Each T In mang For Each T1 In T If InStr(T1.Text, "#") = 0 Then If Len(T1.Value) > 0 Then a = a + 1 arr(a) = T1.Value End If End If Next Next If dk = True Then chuyendulieu = arr(Numb) Else chuyendulieu = Application.Transpose(arr(Numb)) End If End Function
Hoặc kéo theo cột: =chuyendulieu(FALSE,COLUMN(A$1),$C$2:$E$6)
Đây là file chính thức hay chưa bạn, có thay đổi hay điều kiện gì nữa không?Cảm ơn bạn @snow25
Bạn ơi sao nó phát sinh ra những số "0" nhỉ
Bạn xem và chỉnh sửa giúp mình nhé
Bài đã được tự động gộp:
Cảm ơn bạn @
leonguyenz
công thức hay quá, không phải dùng công thức mảng
Nhưng công thức của bạn vẫn phát sinh ra số "0"
Vậy nhờ bạn chỉnh sửa giúp mình nhé
Xin trân thành cảm ơn!
Function chuyendulieu(ByVal dk As Boolean, Numb As Integer, ParamArray mang())
Dim arr(1 To 1000), T, T1, a As Long
For Each T In mang
For Each T1 In T
If InStr(T1.Text, "#") = 0 Then
If Len(T1.Value) > 0 Then
a = a + 1
arr(a) = T1.Value
End If
End If
Next
Next
If a < Numb Then
chuyendulieu = ""
ElseIf dk = True Then
chuyendulieu = arr(Numb)
Else
chuyendulieu = Application.Transpose(arr(Numb))
End If
End Function
Nhờ các bạn trên diễn đàn viết giúp hàm như file đính kèm
Function JoinData(ByVal id As Long, ParamArray sRng()) As Variant
Dim Res, Rng, Cel, k As Long
JoinData = ""
For Each Rng In sRng
For Each Cel In Rng
Res = Cel.Value
If TypeName(Res) <> "Error" Then
If Len(Res) > 0 Then
k = k + 1
If k = id Then JoinData = Res: Exit Function
End If
End If
Next
Next
End Function
Hay quá bạnVậy sửa thêm một chút:
Mã:Function chuyendulieu(ByVal dk As Boolean, Numb As Integer, ParamArray mang()) Dim arr(1 To 1000), T, T1, a As Long For Each T In mang For Each T1 In T If InStr(T1.Text, "#") = 0 Then If Len(T1.Value) > 0 Then a = a + 1 arr(a) = T1.Value End If End If Next Next If a < Numb Then chuyendulieu = "" ElseIf dk = True Then chuyendulieu = arr(Numb) Else chuyendulieu = Application.Transpose(arr(Numb)) End If End Function
Bạn trả lời bài #11 trước nhé.Hay quá bạn
leonguyenz
Cảm ơn bạn!
Bạn thêm cho mình 1 điều kiện nữa được không?
Thêm điều kiện cho trường hợp không lấy trùng
Mong bạn sửa giúp thêm điều kiện nữa nhé!
BạnBạn trả lời bài #11 trước nhé.
Chào bạn @CHAOQUAY bài này tiêu chí của mình là:Đây là file chính thức hay chưa bạn, có thay đổi hay điều kiện gì nữa không?
Hay quá hay quá, code rất ngắn gọnMã:Function JoinData(ByVal id As Long, ParamArray sRng()) As Variant Dim Res, Rng, Cel, k As Long JoinData = "" For Each Rng In sRng For Each Cel In Rng Res = Cel.Value If TypeName(Res) <> "Error" Then If Len(Res) > 0 Then k = k + 1 If k = id Then JoinData = Res: Exit Function End If End If Next Next End Function
Function chuyendulieu(ByVal dK As Boolean, Numb As Integer, ParamArray Mang())
Application.ScreenUpdating = False
Dim Arr(1 To 1000), T, T1, a As Long
For Each T In Mang
For Each T1 In T
If InStr(T1.Text, "#") = 0 Then
If Len(T1.Value) > 0 Then
a = a + 1
Arr(a) = T1.Value
End If
End If
Next
Next
Dim Dic As Object
Dim iR As Long, kR As Long, Tmp As String, dArr
ReDim dArr(1 To UBound(Arr))
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
For iR = 1 To UBound(Arr)
Tmp = Arr(iR)
If Not .Exists(Tmp) Then
kR = kR + 1
.Add Tmp, kR
dArr(kR) = Arr(iR)
End If
Next iR
End With
If kR - 1 < Numb Then
chuyendulieu = ""
ElseIf dK = True Then
chuyendulieu = dArr(Numb)
Else
chuyendulieu = Application.Transpose(dArr(Numb))
End If
Application.ScreenUpdating = True
End Function
Cảm ơn bạnTrên code của bạn snow25, thêm Dic vào để lọc duy nhất.
Mã:Function chuyendulieu(ByVal dK As Boolean, Numb As Integer, ParamArray Mang()) Application.ScreenUpdating = False Dim Arr(1 To 1000), T, T1, a As Long For Each T In Mang For Each T1 In T If InStr(T1.Text, "#") = 0 Then If Len(T1.Value) > 0 Then a = a + 1 Arr(a) = T1.Value End If End If Next Next Dim Dic As Object Dim iR As Long, kR As Long, Tmp As String, dArr ReDim dArr(1 To UBound(Arr)) Set Dic = CreateObject("Scripting.Dictionary") With Dic For iR = 1 To UBound(Arr) Tmp = Arr(iR) If Not .Exists(Tmp) Then kR = kR + 1 .Add Tmp, kR dArr(kR) = Arr(iR) End If Next iR End With If kR - 1 < Numb Then chuyendulieu = "" ElseIf dK = True Then chuyendulieu = dArr(Numb) Else chuyendulieu = Application.Transpose(dArr(Numb)) End If Application.ScreenUpdating = True End Function
Không phải tách riêng đâu. Bạn nên test thử trước khi đặt câu hỏi.
Cảm ơn bạnKhông phải tách riêng đâu. Bạn nên test thử trước khi đặt câu hỏi.
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2