Dùng VBA đưa dữ liệu vào Data Validation

[tan.ngohoangquoc]

Hi mọi người,

Em có viết một vòng lặp để đưa dữ liệu vào Data Validation
Tuy nhiên phải qua 2 vòng lặp em mới loại bỏ dc dữ liệu dư ( các dấu ,,,,,,) trong Validation.
Mọi người có cách nào nhanh hơn không ạ.

Function SetUpValidation(aRange As String)    Dim i As Long, j As Long, k As Long, Validation_List As String
    Dim Dic As Object, Arr(), sArr(), aValidation, sRange As Range
    Application.ScreenUpdating = False
    Set sRange = Sheets("Allocation").Range("TableAllocation[" & aRange & "]")
    Arr = sRange
    ReDim sArr(1 To UBound(Arr), 1 To 1)
        Set Dic = CreateObject("Scripting.Dictionary")
            On Error Resume Next
            For i = 1 To UBound(Arr, 1)
                If Not Dic.exists(Arr(i, 1)) Then
                    Dic.Add Arr(i, 1), 1
                    j = j + 1
                    sArr(j, 1) = Arr(i, 1)
                End If
            Next
    ReDim aValidation(1 To j, 1 To 1)
    For k = 1 To j
        aValidation(k, 1) = sArr(k, 1)
    Next
    Validation_List = Join(WorksheetFunction.Transpose(aValidation), ",")
            With Range("B1").Validation
              .Delete
              .Add 3, , , Validation_List
              .IgnoreBlank = True
            End With
        Set Dic = Nothing
    Application.ScreenUpdating = True
End Function

Tiện thể đây Em dùng code nối chuỗi của thầy ndu. Mà dùng Scripting.Dictionary để lọc trùng luôn mà không xong

Function MergeContent(ByVal Delimiter As String, ParamArray Arrays()) As String  Dim aTmp, Arr(), Item, tmp As String
  Dim i As Long, n As Long
  On Error Resume Next
  For i = LBound(Arrays) To UBound(Arrays)
    aTmp = Arrays(i)
    If Not IsArray(aTmp) Then aTmp = Array(aTmp)
    For Each Item In aTmp
      tmp = IIf(TypeName(Item) = "Error", "", Trim(CStr(Item)))
      If Len(tmp) Then
        n = n + 1
        ReDim Preserve Arr(1 To n)
        Arr(n) = tmp
      End If
    Next
  Next
  If n Then MergeContent = Join(Arr, Delimiter)
End Function

 

[ndu96081631]

Tiện thể đây Em dùng code nối chuỗi của thầy ndu. Mà dùng Scripting.Dictionary để lọc trùng luôn mà không xong

Function [B][COLOR=#ff0000]MergeContent[/COLOR][/B](ByVal Delimiter As String, ParamArray Arrays()) As String
  Dim aTmp, Arr(), Item, tmp As String
  Dim i As Long, n As Long
  On Error Resume Next
  For i = LBound(Arrays) To UBound(Arrays)
    aTmp = Arrays(i)
    If Not IsArray(aTmp) Then aTmp = Array(aTmp)
    For Each Item In aTmp
      tmp = IIf(TypeName(Item) = "Error", "", Trim(CStr(Item)))
      If Len(tmp) Then
        n = n + 1
        ReDim Preserve Arr(1 To n)
        Arr(n) = tmp
      End If
    Next
  Next
  If n Then MergeContent = Join(Arr, Delimiter)
End Function

Hàm gốc của người ta rõ ràng tên là JOINTEXT, tự dưng sửa thành MergeContent ---> Nhìn là thấy.. không ưa rồi

 

[siwtom]

Hi mọi người,

Em có viết một vòng lặp để đưa dữ liệu vào Data Validation
Tuy nhiên phải qua 2 vòng lặp em mới loại bỏ dc dữ liệu dư ( các dấu ,,,,,,) trong Validation.
Mọi người có cách nào nhanh hơn không ạ.

Function SetUpValidation(aRange As String)    Dim i As Long, j As Long, k As Long, Validation_List As String
    Dim Dic As Object, Arr(), sArr(), aValidation, sRange As Range
    Application.ScreenUpdating = False
    Set sRange = Sheets("Allocation").Range("TableAllocation[" & aRange & "]")
    Arr = sRange
    ReDim sArr(1 To UBound(Arr), 1 To 1)
        Set Dic = CreateObject("Scripting.Dictionary")
            On Error Resume Next
            For i = 1 To UBound(Arr, 1)
                If Not Dic.exists(Arr(i, 1)) Then
                    Dic.Add Arr(i, 1), 1
                    j = j + 1
                    sArr(j, 1) = Arr(i, 1)
                End If
            Next
    ReDim aValidation(1 To j, 1 To 1)
    For k = 1 To j
        aValidation(k, 1) = sArr(k, 1)
    Next
    Validation_List = Join(WorksheetFunction.Transpose(aValidation), ",")
            With Range("B1").Validation
              .Delete
              .Add 3, , , Validation_List
              .IgnoreBlank = True
            End With
        Set Dic = Nothing
    Application.ScreenUpdating = True
End Function

Không có tập tin nên tôi nhìn code để đoán bạn làm gì thôi.
Tôi dùng Sub vì bạn chả tính toán và trả về giá trị nào cả. Dùng Function không sai nhưng "gượng gạo" quá.

Sub SetUpValidation(aRange As String)
Dim i As Long, Validation_List As String
Dim Dic As Object, Arr()
    Arr = Sheets("Allocation").Range([COLOR=#ff0000]aRange[/COLOR]).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Arr, 1)
        If Arr(i, 1) <> "" And Not Dic.exists(Arr(i, 1)) Then Dic.Add Arr(i, 1), ""
    Next
    Validation_List = Join(Dic.keys, ",")
    With Range("B1").Validation
      .Delete
      .Add xlValidateList, , , Validation_List
    End With
    Set Dic = Nothing
End Sub

Sub test()
    SetUpValidation "[COLOR=#ff0000]C4:C15[/COLOR]"
End Sub

Nếu bạn vẫn cố tình dùng TableAllocation gì đó thì sửa đỏ đỏ

Không dùng thêm bất cứ hàm UDF nào

 

[tan.ngohoangquoc]

Hàm gốc của người ta rõ ràng tên là JOINTEXT, tự dưng sửa thành MergeContent ---> Nhìn là thấy.. không ưa rồi

Sorry thấy. ............

 

[Quang_Hải]

Ngứa ngứa tay nên code validation kiểu này cho gọn
Cũng đoán đoán code cho vui, trật thì coi như xí hụt.
Cái chỗ your_range muốn thay gì thì tùy, chẳng hạn "A1:A10000"

Sub SetValidation()
   Sheets("Allocation").Range(your_range).AdvancedFilter 2, , [IV1], 1
   [B1].Validation.Delete
   [B1].Validation.Add 3, , , "=" & Range([IV2], [IV65536].End(3)).Address
End Sub

 

[Tuan_hcth]

Em chào anh, chị
Trường hợp em muốn in tự động theo danh sách list trong data validation thì phải thực hiện thế nào ạ. Ý em là duyệt qua từng tên trong data validation để in.

 

[maiban1986]

Ngứa ngứa tay nên code validation kiểu này cho gọn
Cũng đoán đoán code cho vui, trật thì coi như xí hụt.
Cái chỗ your_range muốn thay gì thì tùy, chẳng hạn "A1:A10000"

Sub SetValidation()
   Sheets("Allocation").Range(your_range).AdvancedFilter 2, , [IV1], 1
   [B1].Validation.Delete
   [B1].Validation.Add 3, , , "=" & Range([IV2], [IV65536].End(3)).Address
End Sub

rất hay cám ơn Anh. tiện thể anh cho hỏi ví dụ khi dữ liệu được thêm vào vùng từ a1:a1000 làm cách nào nó updat thêm dữ liệu vào được

 

[Quang_Hải]

rất hay cám ơn Anh. tiện thể anh cho hỏi ví dụ khi dữ liệu được thêm vào vùng từ a1:a1000 làm cách nào nó updat thêm dữ liệu vào được

Sửa câu lệnh này
Range([IV2], [IV65536].End(3)).Address

Thành
Range("A1", [A65536].End(3)).Address

 

[maiban1986]

Sửa câu lệnh này
Range([IV2], [IV65536].End(3)).Address

Thành
Range("A1", [A65536].End(3)).Address

không được anh ah

 

[huuthang_bd]

Dùng name động khỏe hơn.

 

[maiban1986]

Dùng name động khỏe hơn.

dùng name là phải dùng công thức đúng không anh

 

[huuthang_bd]

dùng name là phải dùng công thức đúng không anh

Đúng vậy, phần lọc duy nhất vẫn dùng Advance Filter bằng code nhưng Validation thì cố định bằng 1 name động.

 

[Doãn Quốc Bình]

Ngứa ngứa tay nên code validation kiểu này cho gọn
Cũng đoán đoán code cho vui, trật thì coi như xí hụt.
Cái chỗ your_range muốn thay gì thì tùy, chẳng hạn "A1:A10000"

Sub SetValidation()
   Sheets("Allocation").Range(your_range).AdvancedFilter 2, , [IV1], 1
   [B1].Validation.Delete
   [B1].Validation.Add 3, , , "=" & Range([IV2], [IV65536].End(3)).Address
End Sub

Cảm ơn Bác Quang_Hải nhiều nhiều ạ, khi dùng thì your_range cần các dòng đều phải có dữ liệu nếu có dòng trống thì code của bác báo lỗi Run-time error '1004', xin bác giúp em làm sao để khi có dòng trống thì vẫn add được datavalidation với ạ. em xin cảm ơn ạ.