Hàm trả về chuỗi giá trị trong

[nobita1985]

Em viết một hàm trong VBA, Hàm này tham chiếu đến một vùng dữ liệu trong bảng tính Ecxel, và duyệt dữ liệu trong từng cell nếu giá trị cell bằng 0 thì bỏ qua, nếu giá trị của cell khác không thì lấy giá trị trong ô cell đó thêm vào dấu cộng nối với giá trị ô cell khác 0 kê tiếp. Kết quả trả về là dẫy giá trị nối với nhau qua dấu "+" ví dụ:
ô tham chiếu {1,0,2,3,0,4} giá trị trả về "1+2+3+4". Khi chay thử báo lỗi #value. Mong các anh chị giúp đỡ em lập hàm này.
Code:
Option Explicit
Option Base 1
Public Function TraVeText(Dulieu As Range) As String
Dim Text() As String
Dim Sophantu As Integer
Sophantu = 0
Dim i As Integer
i = 0

For Each Dulieu In Dulieu.Cells
If Dulieu.Value <> 0 Then
Sophantu = Sophantu + 1
End If
Next Dulieu ' Da kiem tra ok
ReDim Text(Sophantu) As String ' Da kiem tra ok gan dc mang.
i = 1

For Each Dulieu In Dulieu.Cells
If Dulieu.Value <> 0 Then
Text(i) = Dulieu.Value
i = i + 1
End If
Next Dulieu
TraVeText = Join(Text(), "+")
End Function

 

[ndu96081631]

Em viết một hàm trong VBA, Hàm này tham chiếu đến một vùng dữ liệu trong bảng tính Ecxel, và duyệt dữ liệu trong từng cell nếu giá trị cell bằng 0 thì bỏ qua, nếu giá trị của cell khác không thì lấy giá trị trong ô cell đó thêm vào dấu cộng nối với giá trị ô cell khác 0 kê tiếp. Kết quả trả về là dẫy giá trị nối với nhau qua dấu "+" ví dụ:
ô tham chiếu {1,0,2,3,0,4} giá trị trả về "1+2+3+4". Khi chay thử báo lỗi #value. Mong các anh chị giúp đỡ em lập hàm này.
Code:
Option Explicit
Option Base 1
Public Function TraVeText(Dulieu As Range) As String
Dim Text() As String
Dim Sophantu As Integer
Sophantu = 0
Dim i As Integer
i = 0

For Each Dulieu In Dulieu.Cells
If Dulieu.Value <> 0 Then
Sophantu = Sophantu + 1
End If
Next Dulieu ' Da kiem tra ok
ReDim Text(Sophantu) As String ' Da kiem tra ok gan dc mang.
i = 1

For Each Dulieu In Dulieu.Cells
If Dulieu.Value <> 0 Then
Text(i) = Dulieu.Value
i = i + 1
End If
Next Dulieu
TraVeText = Join(Text(), "+")
End Function

Tặng bạn cái này:

Function JoinText(ByVal Sep As String, ByVal IgnoreBlanks As Boolean, ParamArray sArray()) As String
  Dim tmpArr, SubArr, Arr(), Item, n As Long
  On Error Resume Next
  For Each SubArr In sArray
    tmpArr = SubArr
    If TypeName(tmpArr) <> "Variant()" Then
      If IgnoreBlanks = False Or Len(Trim(CStr(tmpArr))) > 0 Then
        n = n + 1
        ReDim Preserve Arr(1 To n)
        Arr(n) = CStr(tmpArr)
      End If
    Else
      For Each Item In tmpArr
        If IgnoreBlanks = False Or Len(Trim(CStr(Item))) > 0 Then
          n = n + 1
          ReDim Preserve Arr(1 To n)
          Arr(n) = CStr(Item)
        End If
      Next
    End If
  Next
  If n Then JoinText = Join(Arr, Sep)
End Function

Cú pháp: JoinText(Dấu phân cách, Bỏ qua phần tử rổng hay không?, Dữ liệu)
Áp dụng vào file của bạn: =JoinText("+",TRUE,C6:C10)
---------------------
Hàm này có thể áp dụng cho Array hoặc Range... Có thể lấy dữ liệu từ nhiều vùng không liên tục... vân vân...