Sửa giúp code dồn số liệu (1 người xem)

hiénlinh197 · 30/4/18

Nhờ các bạn sửa giúp code theo file đính kèm,
Cảm ơn các bạn!

HieuCD · 30/4/18

hiénlinh197 đã viết:
Nhờ các bạn sửa giúp code theo file đính kèm,
Cảm ơn các bạn!

Thử code

Mã:

Sub Rectangle1_Click()
    Dim Arr(), kq(), i As Long, j As Long, k As Long, jMax As Long
    Arr = Sheet1.Range("l3:z22").Value
    ReDim kq(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    For i = 1 To UBound(Arr, 1)
        k = 0
        For j = 1 To UBound(Arr, 2)
            If Arr(i, j) <> "" Then
                k = k + 1
                kq(i, k) = Arr(i, j)
            End If
        Next j
        If jMax < k Then jMax = k 'Tính só cot ket qua
    Next i
    Sheet1.Range("A3").Resize(UBound(kq, 1), jMax).Value = kq
End Sub

Nếu không đúng ý thì nhập kết quả và gởi lên

hiénlinh197 · 30/4/18

HieuCD đã viết:

Thử code

Mã:

Sub Rectangle1_Click()
    Dim Arr(), kq(), i As Long, j As Long, k As Long, jMax As Long
    Arr = Sheet1.Range("l3:z22").Value
    ReDim kq(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    For i = 1 To UBound(Arr, 1)
        k = 0
        For j = 1 To UBound(Arr, 2)
            If Arr(i, j) <> "" Then
                k = k + 1
                kq(i, k) = Arr(i, j)
            End If
        Next j
        If jMax < k Then jMax = k 'Tính só cot ket qua
    Next i
    Sheet1.Range("A3").Resize(UBound(kq, 1), jMax).Value = kq
End Sub

Nếu không đúng ý thì nhập kết quả và gởi lên

Cảm ơn anh
HieuCD
. Anh ơi nhưng em muốn là các số trùng nhau thì chỉ lấy 1 số . anh sửa giúp em với nhé!

HieuCD · 30/4/18

hiénlinh197 đã viết:
Cảm ơn anh
HieuCD
. Anh ơi nhưng em muốn là các số trùng nhau thì chỉ lấy 1 số . anh sửa giúp em với nhé!

Mã:

Sub Rectangle1_Click()
    Dim Arr(), kq(), i As Long, j As Long, k As Long, jMax As Long, key As String
    Arr = Sheet1.Range("l3:z22").Value
    ReDim kq(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            k = 0
            For j = 1 To UBound(Arr, 2)
                key = CStr(Arr(i, j))
                If key <> "" Then
                    If Not .exists(key) Then
                        .Add key, ""
                        k = k + 1
                        kq(i, k) = key
                    End If
                End If
            Next j
            .RemoveAll 'Neu loai trung tat ca dòng thì bo lenh nay
            If jMax < k Then jMax = k 'Tính só cot ket qua
        Next i
    End With
    Sheet1.Range("A3").Resize(UBound(kq, 1), jMax).Value = kq
End Sub

hiénlinh197 · 30/4/18

HieuCD đã viết:

Mã:

Sub Rectangle1_Click()
    Dim Arr(), kq(), i As Long, j As Long, k As Long, jMax As Long, key As String
    Arr = Sheet1.Range("l3:z22").Value
    ReDim kq(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            k = 0
            For j = 1 To UBound(Arr, 2)
                key = CStr(Arr(i, j))
                If key <> "" Then
                    If Not .exists(key) Then
                        .Add key, ""
                        k = k + 1
                        kq(i, k) = key
                    End If
                End If
            Next j
            .RemoveAll 'Neu loai trung tat ca dòng thì bo lenh nay
            If jMax < k Then jMax = k 'Tính só cot ket qua
        Next i
    End With
    Sheet1.Range("A3").Resize(UBound(kq, 1), jMax).Value = kq
End Sub

Cảm ơn anh rất nhiều, code chạy rất chuẩn anh à, Nhưng bây giờ anh giúp em chút síu nữa là khi muốn dồn 2 hoặc nhiều mảng không liền kề nhau thì làm như nào?

HieuCD · 30/4/18

hiénlinh197 đã viết:
Cảm ơn anh rất nhiều, code chạy rất chuẩn anh à, Nhưng bây giờ anh giúp em chút síu nữa là khi muốn dồn 2 hoặc nhiều mảng không liền kề nhau thì làm như nào?

Thêm vòng lập tính dòng cuối mảng dữ liệu, bạn có thể nhìn bảng và nhập trực tiếp vào lệnh tạo mảng Arr

Mã:

Sub donso() 'Hieucd b2
    Dim Arr(), kq(), i As Long, j As Long, k As Long, jMax As Long, key As String
    For j = 12 To 26 'Cot L toi cot Z
      i = Cells(65500, j).End(xlUp).Row 'dòng cuoi cot j
      If i > k Then k = i 'dòng cuoi cua mang du lieu
    Next j
    Arr = Sheet1.Range("L3:Z" & k).Value
    ReDim kq(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            k = 0
            For j = 1 To UBound(Arr, 2)
                key = CStr(Arr(i, j))
                If key <> "" Then
                    If Not .exists(key) Then
                        .Add key, ""
                        k = k + 1
                        kq(i, k) = key
                    End If
                End If
            Next j
            .RemoveAll 'Neu loai trung tat ca dòng thì bo lenh nay
            If jMax < k Then jMax = k 'Tính só cot ket qua
        Next i
    End With
    Sheet1.Range("A3").Resize(UBound(kq, 1), jMax).Value = kq
End Sub

hiénlinh197 · 1/5/18

HieuCD đã viết:

Thêm vòng lập tính dòng cuối mảng dữ liệu, bạn có thể nhìn bảng và nhập trực tiếp vào lệnh tạo mảng Arr

Mã:

Sub donso() 'Hieucd b2
    Dim Arr(), kq(), i As Long, j As Long, k As Long, jMax As Long, key As String
    For j = 12 To 26 'Cot L toi cot Z
      i = Cells(65500, j).End(xlUp).Row 'dòng cuoi cot j
      If i > k Then k = i 'dòng cuoi cua mang du lieu
    Next j
    Arr = Sheet1.Range("L3:Z" & k).Value
    ReDim kq(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            k = 0
            For j = 1 To UBound(Arr, 2)
                key = CStr(Arr(i, j))
                If key <> "" Then
                    If Not .exists(key) Then
                        .Add key, ""
                        k = k + 1
                        kq(i, k) = key
                    End If
                End If
            Next j
            .RemoveAll 'Neu loai trung tat ca dòng thì bo lenh nay
            If jMax < k Then jMax = k 'Tính só cot ket qua
        Next i
    End With
    Sheet1.Range("A3").Resize(UBound(kq, 1), jMax).Value = kq
End Sub

HieuCD đã viết:

Thêm vòng lập tính dòng cuối mảng dữ liệu, bạn có thể nhìn bảng và nhập trực tiếp vào lệnh tạo mảng Arr

Mã:

Sub donso() 'Hieucd b2
    Dim Arr(), kq(), i As Long, j As Long, k As Long, jMax As Long, key As String
    For j = 12 To 26 'Cot L toi cot Z
      i = Cells(65500, j).End(xlUp).Row 'dòng cuoi cot j
      If i > k Then k = i 'dòng cuoi cua mang du lieu
    Next j
    Arr = Sheet1.Range("L3:Z" & k).Value
    ReDim kq(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            k = 0
            For j = 1 To UBound(Arr, 2)
                key = CStr(Arr(i, j))
                If key <> "" Then
                    If Not .exists(key) Then
                        .Add key, ""
                        k = k + 1
                        kq(i, k) = key
                    End If
                End If
            Next j
            .RemoveAll 'Neu loai trung tat ca dòng thì bo lenh nay
            If jMax < k Then jMax = k 'Tính só cot ket qua
        Next i
    End With
    Sheet1.Range("A3").Resize(UBound(kq, 1), jMax).Value = kq
End Sub

Em cảm ơn anh
HieuCD
, rất chuẩn anh à! Bây giờ em muốn dồn kết quả vào 1 dòng thì phải làm như nào hả anh? Em loay hoay mãi từ đêm qua tới bây giờ mà vẫn chưa sửa được. Anh sửa giúp em với. Cảm ơn anh rất nhiều.

HieuCD · 1/5/18

hiénlinh197 đã viết:
Em cảm ơn anh
HieuCD
, rất chuẩn anh à! Bây giờ em muốn dồn kết quả vào 1 dòng thì phải làm như nào hả anh? Em loay hoay mãi từ đêm qua tới bây giờ mà vẫn chưa sửa được. Anh sửa giúp em với. Cảm ơn anh rất nhiều.

Nhập tay kết quả gởi lên

hiénlinh197 · 1/5/18

HieuCD đã viết:
Nhập tay kết quả gởi lên

Dạ cảm ơn anh!

HieuCD · 1/5/18

hiénlinh197 đã viết:
Dạ cảm ơn anh!

Mã:

Sub donso() 'Hieucd b3 (Láy nhieu mang)
    Dim Arr(), kq(), i As Long, j As Long, k As Long, jMax As Long, key
    For j = 12 To 26 'Cot L toi cot Z
      i = Cells(65500, j).End(xlUp).Row 'dòng cuoi cot j
      If i > k Then k = i 'dòng cuoi cua mang du lieu
    Next j
    Arr = Sheet1.Range("L4:Z" & k).Value
    k = 0
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            For j = 1 To UBound(Arr, 2)
                key = Arr(i, j)
                If TypeName(key) = "Double" Then
                    If Not .exists(key) Then
                        .Add key, ""
                        k = k + 1
                        ReDim Preserve kq(1 To k)
                        kq(k) = key
                    End If
                End If
            Next j
        Next i
    End With
    Sheet1.Range("B2").Resize(, k).Value = kq
End Sub

batman1 · 1/5/18

Thử rút gọn code của bạn HieuCD

Mã:

Sub donso() 'Hieucd b3 (Láy nhieu mang)
Dim Arr(), i As Long, j As Long, k As Long, key
    For j = 12 To 26 'Cot L toi cot Z
        i = Sheet1.Cells(Rows.Count, j).End(xlUp).Row 'dong cuoi cot j
        If i > k Then k = i 'dong cuoi cua mang du lieu
    Next j
    Arr = Sheet1.Range("L4:Z" & k).Value
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            For j = 1 To UBound(Arr, 2)
                key = Arr(i, j)
                If TypeName(key) = "Double" Then
                    If Not .exists(key) Then .Add key, ""
                End If
            Next j
        Next i
        Sheet1.Range("B2").Resize(, .Count).Value = .keys()
    End With
End Sub

hiénlinh197 · 2/5/18

HieuCD đã viết:

Mã:

Sub donso() 'Hieucd b3 (Láy nhieu mang)
    Dim Arr(), kq(), i As Long, j As Long, k As Long, jMax As Long, key
    For j = 12 To 26 'Cot L toi cot Z
      i = Cells(65500, j).End(xlUp).Row 'dòng cuoi cot j
      If i > k Then k = i 'dòng cuoi cua mang du lieu
    Next j
    Arr = Sheet1.Range("L4:Z" & k).Value
    k = 0
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            For j = 1 To UBound(Arr, 2)
                key = Arr(i, j)
                If TypeName(key) = "Double" Then
                    If Not .exists(key) Then
                        .Add key, ""
                        k = k + 1
                        ReDim Preserve kq(1 To k)
                        kq(k) = key
                    End If
                End If
            Next j
        Next i
    End With
    Sheet1.Range("B2").Resize(, k).Value = kq
End Sub

Cảm ơn anh
HieuCD!
code rất tuyệt vời anh à! Chúc anh công tác tốt và gặp nhiều may mắn mọi điều an lành.

hiénlinh197 · 2/5/18

batman1 đã viết:

Thử rút gọn code của bạn HieuCD

Mã:

Sub donso() 'Hieucd b3 (Láy nhieu mang)
Dim Arr(), i As Long, j As Long, k As Long, key
    For j = 12 To 26 'Cot L toi cot Z
        i = Sheet1.Cells(Rows.Count, j).End(xlUp).Row 'dong cuoi cot j
        If i > k Then k = i 'dong cuoi cua mang du lieu
    Next j
    Arr = Sheet1.Range("L4:Z" & k).Value
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            For j = 1 To UBound(Arr, 2)
                key = Arr(i, j)
                If TypeName(key) = "Double" Then
                    If Not .exists(key) Then .Add key, ""
                End If
            Next j
        Next i
        Sheet1.Range("B2").Resize(, .Count).Value = .keys()
    End With
End Sub

Cảm ơn bạn
batman1
đã rút gọn code, chạy rất tốt, nhưng có điều là không xóa dữ liệu cũ đi nên hay bị nhầm dữ liệu.

befaint · 2/5/18

Lâu không ôn lại bài cũ...
Dùng ArrayList chắc gọn hơn vì có hàm copy mảng.

batman1 · 2/5/18

hiénlinh197 đã viết:
Cảm ơn bạn
batman1
đã rút gọn code, chạy rất tốt, nhưng có điều là không xóa dữ liệu cũ đi nên hay bị nhầm dữ liệu.

Code đó có phải của tôi đâu?
Tôi thấy bạn "thích" nên nghĩ là bạn hài lòng rồi.
Tôi viết rõ mà

Thử rút gọn code của bạn HieuCD

Rút gọn thôi chứ không thêm.

hiénlinh197 · 2/5/18

batman1 đã viết:
Code đó có phải của tôi đâu?
Tôi thấy bạn "thích" nên nghĩ là bạn hài lòng rồi.
Tôi viết rõ mà

Rút gọn thôi chứ không thêm.

Vâng! Cảm ơn bạn nhe!

ndu96081631 · 2/5/18

hiénlinh197 đã viết:
Nhờ các bạn sửa giúp code theo file đính kèm,
Cảm ơn các bạn!

Bài này trước đây tôi có làm 1 lần, nó thế này:
1> Viết 1 hàm lọc duy nhất

Mã:

Function UniqueList(ParamArray Arrays())
  Dim item, aTmpArr, aSubArr
  'On Error Resume Next
  With CreateObject("Scripting.Dictionary")
    For Each aSubArr In Arrays
      aTmpArr = aSubArr
      If Not IsArray(aTmpArr) Then aTmpArr = Array(aTmpArr)
      For Each item In aTmpArr
        If TypeName(item) <> "Error" Then
          If Len(item) Then
            If Not .exists(item) Then .Add item, Empty
          End If
        End If
      Next
    Next
    If .Count Then UniqueList = .Keys
  End With
End Function

2> Code áp dụng:

Mã:

Sub Main()
  Dim Arr
  Arr = UniqueList(Range("L4:Z23"), Range("L31:Z50"))
  If IsArray(Arr) Then Range("B2").Resize(, UBound(Arr) + 1).Value = Arr
End Sub

hiénlinh197 · 2/5/18

ndu96081631 đã viết:

Bài này trước đây tôi có làm 1 lần, nó thế này:
1> Viết 1 hàm lọc duy nhất

Mã:

Function UniqueList(ParamArray Arrays())
  Dim item, aTmpArr, aSubArr
  'On Error Resume Next
  With CreateObject("Scripting.Dictionary")
    For Each aSubArr In Arrays
      aTmpArr = aSubArr
      If Not IsArray(aTmpArr) Then aTmpArr = Array(aTmpArr)
      For Each item In aTmpArr
        If TypeName(item) <> "Error" Then
          If Len(item) Then
            If Not .exists(item) Then .Add item, Empty
          End If
        End If
      Next
    Next
    If .Count Then UniqueList = .Keys
  End With
End Function

2> Code áp dụng:

Mã:

Sub Main()
  Dim Arr
  Arr = UniqueList(Range("L4:Z23"), Range("L31:Z50"))
  If IsArray(Arr) Then Range("B2").Resize(, UBound(Arr) + 1).Value = Arr
End Sub

Cảm ơn bác
ndu96081631
đã quan tâm vấn đề và giúp đỡ. Nhưng bác
ndu96081631
vẫn chưa xóa dữ liệu cũ đi bác à.

hiénlinh197 · 2/5/18

ndu96081631 đã viết:

Bài này trước đây tôi có làm 1 lần, nó thế này:
1> Viết 1 hàm lọc duy nhất

Mã:

Function UniqueList(ParamArray Arrays())
  Dim item, aTmpArr, aSubArr
  'On Error Resume Next
  With CreateObject("Scripting.Dictionary")
    For Each aSubArr In Arrays
      aTmpArr = aSubArr
      If Not IsArray(aTmpArr) Then aTmpArr = Array(aTmpArr)
      For Each item In aTmpArr
        If TypeName(item) <> "Error" Then
          If Len(item) Then
            If Not .exists(item) Then .Add item, Empty
          End If
        End If
      Next
    Next
    If .Count Then UniqueList = .Keys
  End With
End Function

2> Code áp dụng:

Mã:

Sub Main()
  Dim Arr
  Arr = UniqueList(Range("L4:Z23"), Range("L31:Z50"))
  If IsArray(Arr) Then Range("B2").Resize(, UBound(Arr) + 1).Value = Arr
End Sub

Trời, em chưa để ý bác
ndu96081631
à, code này thuận tiện quá bác ndu96081631 à, Không phải thêm nhiều vòng lặp mà vẫn dồn cho nhiều mảng, bác bận tâm thêm cho em dòng xoa dữ cũ liệu vào với nhé, Cảm ơn bác!

befaint · 2/5/18

Xóa dòng 2:

PHP:

Sheet1.Rows(2).ClearContents
'Hoặc:'
'Sheet1.Range("A2").Resize(1, Columns.Count).ClearContents

hiénlinh197 · 2/5/18

befaint đã viết:
Xóa dòng 2:

PHP:

Sheet1.Rows(2).ClearContents 'Hoặc:' 'Sheet1.Range("A2").Resize(1, Columns.Count).ClearContents

Rất cảm ơn bạn
befaint

ndu96081631 · 2/5/18

hiénlinh197 đã viết:
bác bận tâm thêm cho em dòng xoa dữ cũ liệu vào với nhé, Cảm ơn bác!

Ở trên đã trả lời rồi nhưng tôi cũng xin gợi ý bạn về cách học để mai này không cần hỏi những câu tương tự như trên nhé!
Đó là nếu bạn không biết code xóa dữ liệu nó như thế nào bạn có thể:
- Bật chức năng record macro lên
- Chọn dòng 2 và xóa
- Tắt record macro
- Bấm Alt + F11 vào xem code
Vậy là bạn có code rồi đó. Những cái đơn giản khác (những cái có thể làm bằng tay) cũng hãy thao tác tương tự để có code

hiénlinh197 · 2/5/18

ndu96081631 đã viết:
Ở trên đã trả lời rồi nhưng tôi cũng xin gợi ý bạn về cách học để mai này không cần hỏi những câu tương tự như trên nhé!
Đó là nếu bạn không biết code xóa dữ liệu nó như thế nào bạn có thể:
- Bật chức năng record macro lên
- Chọn dòng 2 và xóa
- Tắt record macro
- Bấm Alt + F11 vào xem code
Vậy là bạn có code rồi đó. Những cái đơn giản khác (những cái có thể làm bằng tay) cũng hãy thao tác tương tự để có code

vâng! Rất cảm ơn anh ndu96081631, nhưng mà sửa macro khó quá anh à. Anh có thể sửa giúp em là kết quả trả về từng dòng như file em đính kèm được không?
Cảm ơn anh!

befaint · 2/5/18

hiénlinh197 đã viết:
kết quả trả về từng dòng như file em đính kèm

Sao đến bài này lại đổi yêu cầu rồi vậy? Bài trước ra kết quả giống y như file yêu cầu rồi mà!!!

Sao chủ đề nào mình cũng lòng vòng vậy?

hiénlinh197 · 2/5/18

befaint đã viết:
Sao đến bài này lại đổi yêu cầu rồi vậy? Bài trước ra kết quả giống y như file yêu cầu rồi mà!!!

Sao chủ đề nào mình cũng lòng vòng vậy?

Cảm ơn bạn
befaint

đã giúp đỡ, nhưng thật tình mình thích kiểu phong cách viết của bác ndu96081631 ở bài #17, mình chỉ cần cho thêm mảng vào là oke rồi, không cần thêm cái gì nữa "Bởi vìh min chưa hiểu biết và vận dụng code, nên cái gì ngắn gọn là mình sướng rồi"
Bạn có thể giúp mình giống như vậy được không?

batman1 · 2/5/18

hiénlinh197 đã viết:
Cảm ơn bạn
befaint

đã giúp đỡ, nhưng thật tình mình thích kiểu phong cách viết của bác ndu96081631 ở bài #17, mình chỉ cần cho thêm mảng vào là oke rồi, không cần thêm cái gì nữa "Bởi vìh min chưa hiểu biết và vận dụng code, nên cái gì ngắn gọn là mình sướng rồi"
Bạn có thể giúp mình giống như vậy được không?

Bạn không hiểu một điều đơn giản là khi yêu cầu thay đổi thì rất có thể phải viết code mới. Trong trường hợp này thậm chí nếu muốn dùng đoạn code nào đấy trong bài #17 thì cũng phải viết một code dài để "cố gượng ép" dùng (gọi) code đó. Lúc này thì thà đập đi làm mới còn ngắn và nhanh hơn.

hiénlinh197 · 2/5/18

batman1 đã viết:
Bạn không hiểu một điều đơn giản là khi yêu cầu thay đổi thì rất có thể phải viết code mới. Trong trường hợp này thậm chí nếu muốn dùng đoạn code nào đấy trong bài #17 thì cũng phải viết một code dài để "cố gượng ép" dùng (gọi) code đó. Lúc này thì thà đập đi làm mới còn ngắn và nhanh hơn.

Cảm ơn bạn! Nhưng code đó nếu như thêm mảng vào thì có phải thêm các vòng lặp vào nữa không?

batman1 · 2/5/18

hiénlinh197 đã viết:
Cảm ơn bạn! Nhưng code đó nếu như thêm mảng vào thì có phải thêm các vòng lặp vào nữa không?

Nếu tôi hiểu ý của bạn thì khi bạn gọi với tham số là 1 mảng thôi thì kết quả sẽ là một mảng liên tục. Đập xuống sheet thì tùy theo cách đập mà sẽ là 1 dòng kết quả hoặc 1 cột kết quả chứ không phải là nhiều dòng kết quả như bạn ghi trong tập tin.
Bạn vẫn cố tình không hiểu

thậm chí nếu muốn dùng đoạn code nào đấy trong bài #17 thì cũng phải viết một code dài để "cố gượng ép" dùng (gọi) code đó. Lúc này thì thà đập đi làm mới còn ngắn và nhanh hơn.

Mà bạn thì muốn code ngắn mà.

befaint · 2/5/18

Tạm...
Nói chung là thua!

hiénlinh197 · 2/5/18

batman1 đã viết:
Nếu tôi hiểu ý của bạn thì khi bạn gọi với tham số là 1 mảng thôi thì kết quả sẽ là một mảng liên tục. Đập xuống sheet thì tùy theo cách đập mà sẽ là 1 dòng kết quả hoặc 1 cột kết quả chứ không phải là nhiều dòng kết quả như bạn ghi trong tập tin.
Bạn vẫn cố tình không hiểu

Mà bạn thì muốn code ngắn mà.

Bạn batman1 ơi, như file mình đính kèm ở bài #23 đó. Thật sự mình không hiểu nên đôi khi diễn đạt không đúng, bạn thông cảm. Cái này anh @HieuCD cũng viết rồi, nhưng lại phải thêm những vòng lặp để chọn mảng tiếp theo. Mình thấy cũng bất tiện. NHờ bạn sửa giúp mình làm sao như của bác @ndu96081631 là chỉ cần thêm mảng vào là OK.
Cảm ơn bạn rất nhiều!

batman1 · 3/5/18

hiénlinh197 đã viết:
Bạn batman1 NHờ bạn sửa giúp mình làm sao như của bác @ndu96081631 là chỉ cần thêm mảng vào là OK.

Tại sai lại là tôi?
Mà tôi đã nói nhưng bạn cố tình không hiểu.

Lúc này thì thà đập đi làm mới còn ngắn và nhanh hơn.

Chính befaint đang cố "đập đi làm mới". Không còn cách khác đâu.

bótay.com

hiénlinh197 · 3/5/18

befaint đã viết:
Tạm...
Nói chung là thua!

rất tuyệt vơi, tuy nhìn code hơi dài một tý, nhưng chạy rất chuẩn "Không biết tốc độ như nào". Cảm ơn bạn
befaint đã giúp đỡ.

hiénlinh197 · 3/5/18

befaint đã viết:
Tạm...
Nói chung là thua!

Xin lỗi bạn
befaint
Code này của bạn là tùy biến thêm, bớt mảng rất thuận tiện. Nhưng bạn làm là dồn tất cả các số có mặt trong dòng. Nhưng ý của mình là dồn số liệu nếu như có số liệu trùng nhau thì chỉ lấy 1 số liệu là đại diện. Bạn bớt chút thời gian sửa lại giúp mình với nhé!
Cảm ơn bạn!

VetMini · 3/5/18

Mới lượm được đôi dép cùn, lót ngồi xem.
(lỡ bị CA đuổi chạy mất dép cũng không thiệt thòi nhiều)

hiénlinh197 · 3/5/18

VetMini đã viết:
Mới lượm được đôi dép cùn, lót ngồi xem.
(lỡ bị CA đuổi chạy mất dép cũng không thiệt thòi nhiều)

Bác
VetMini
biết gì về VBA, code, hay sub() mà cũng nhảy xen vô đây, may ra bác chỉ biết mấy cái công thức toán lớp 3. Thế mà làm còn sai.

thuyyeu99 · 3/5/18

Đại cao thủ

batman1 · 3/5/18

hiénlinh197 đã viết:
Nhưng bạn làm là dồn tất cả các số có mặt trong dòng.

Mỗi khi có vụ mới thì phải mô tả kỹ để người khác biết mình muốn gì. Rõ ràng là yêu cầu bây giờ khác yêu cầu ban đầu, nên là vấn đề mới, vậy phải mô tả lại từ đầu.

Tập tin phải có dữ liệu "biết nói". Nếu dữ liệu giả lập là 2, 3, 4, 5 và kết quả mong đợi cũng là 2, 3, 4 và 5 thì người khác có thể hiểu là lấy hết các số có trong dòng. Nếu dữ liệu giả lập là 2, 3, 4, 3, 5, 4, 2 mà kết quả mong đợi là 2, 3, 4 và 5 thì người khác sẽ hiểu là chỉ lấy các giá trị khác nhau từng đôi một. Dữ liệu thứ hai là dữ liệu "biết nói"

Hỏi cũng phải biết hỏi, phải suy nghĩ, để khỏi mất thời gian của người khác.

VetMini đã viết:
Mới lượm được đôi dép cùn, lót ngồi xem

Bác cho tôi xin lại được không? Hôm qua tôi xem kịch hay mà bỏ quên.

VetMini · 3/5/18

batman1 đã viết:
...
Bác cho tôi xin lại được không? Hôm qua tôi xem kịch hay mà bỏ quên.

Xin lỗi, tôi mới nhỏm dậy đi một chút mà thằng/con nào lại cuỗm mất rồi.
Giờ đi hóng chuyện lại phải tiếp tục trở về cái thế chồm hổm thôi.

AutoReply · 3/5/18

VetMini đã viết:
Xin lỗi, tôi mới nhỏm dậy đi một chút mà thằng/con nào lại cuỗm mất rồi.
Giờ đi hóng chuyện lại phải tiếp tục trở về cái thế chồm hổm thôi.

Không sao, đến đây ngồi chung nửa cục gạch với mình nè. Mình rất có cảm tình với mấy người chưa rành toán lớp 3 như bạn.
Biết đâu được xem anh bị phèn xây thêm ngôi nhà mới

batman1 · 3/5/18

VetMini đã viết:
Xin lỗi, tôi mới nhỏm dậy đi một chút mà thằng/con nào lại cuỗm mất rồi.
Giờ đi hóng chuyện lại phải tiếp tục trở về cái thế chồm hổm thôi.

Bác nhìn xem gần đó có cô nào có vẻ ngoan ngoan không. Cứ chồm hổm bên cạnh một lúc là thể nào cũng có đối thoại (không phải đối thoại trên sân khấu nhé):
- Cháu có ghế tựa, cháu mời bác ngồi ạ,
- Thôi cô ngồi đi, tôi ngồi thì cô ngồi đâu?
- Cháu ngồi đất cũng được ạ.
- Ngồi đất? Thôi, tôi không dám để cô ngồi đất đâu.
- Bác cứ ngồi đi, cháu chịu được mà.
- Tôi cám ơn, nhưng ghế của cô mà.
-Thôi, nếu bác câu nệ thế thì bác ngồi đi, cháu có thể ngồi trên đùi bác được không? Thế là tốt cho cả hai.
- Nhưng đùi tôi xương cứng lắm ...
- Không sao cả. Cháu quen ngồi vào cái gì đó cứng cứng rồi ...

hiénlinh197 · 3/5/18

batman1 đã viết:
Mỗi khi có vụ mới thì phải mô tả kỹ để người khác biết mình muốn gì. Rõ ràng là yêu cầu bây giờ khác yêu cầu ban đầu, nên là vấn đề mới, vậy phải mô tả lại từ đầu.

Tập tin phải có dữ liệu "biết nói". Nếu dữ liệu giả lập là 2, 3, 4, 5 và kết quả mong đợi cũng là 2, 3, 4 và 5 thì người khác có thể hiểu là lấy hết các số có trong dòng. Nếu dữ liệu giả lập là 2, 3, 4, 3, 5, 4, 2 mà kết quả mong đợi là 2, 3, 4 và 5 thì người khác sẽ hiểu là chỉ lấy các giá trị khác nhau từng đôi một. Dữ liệu thứ hai là dữ liệu "biết nói"

Hỏi cũng phải biết hỏi, phải suy nghĩ, để khỏi mất thời gian của người khác.

Bác cho tôi xin lại được không? Hôm qua tôi xem kịch hay mà bỏ quên.

Chào bác
batman1
Thật sự cái phương án ban đầu thì chỉ có như vậy. Nhưng qua thực tế thì lại phát sinh ra nhiều vấn đề.
Tôi muốn những cái tổng quát, ai ai cũng làm được, không biết VBA như bác giải toán lớp 3 còn sai
VetMini
. Vì vậy bác batman1 thông cảm bỏ qua. Bác sửa lại giúp tôi code của bài #29 với nhé!
Cảm ơn bác,

AutoReply · 3/5/18

hiénlinh197 đã viết:
Chào bác
batman1
Thật sự cái phương án ban đầu thì chỉ có như vậy. Nhưng qua thực tế thì lại phát sinh ra nhiều vấn đề.
Tôi muốn những cái tổng quát, ai ai cũng làm được, không biết VBA như bác giải toán lớp 3 còn sai
VetMini
. Vì vậy bác batman1 thông cảm bỏ qua. Bác sửa lại giúp tôi code của bài #29 với nhé!
Cảm ơn bác,

Coi chừng bạn tìm nhầm người. Mình nghe nói bạn batman1 đếm số 1,2,3,4,5 còn chưa chắc thuộc hết đó, đặt cái tài khoản có gắn số 1 đuôi là tôi nghi rồi.
Sợ bạn batman1 không giúp nổi bạn ấy chứ.

hiénlinh197 · 3/5/18

AutoReply đã viết:
Coi chừng bạn tìm nhầm người. Mình nghe nói bạn batman1 đếm số 1,2,3,4,5 còn chưa chắc thuộc hết đó, đặt cái tài khoản có gắn số 1 đuôi là tôi nghi rồi.
Sợ bạn batman1 không giúp nổi bạn ấy chứ.

Bạn
AutoReply
nhìn nhầm người rồi, "Nhìn mặt mà bắt hình dong". "nhìn mặt gửi vàng" đấy là câu nói của các cụ ngày xưa, Không biết bây giờ có còn đúng hay không? Nhưng theo kinh nghiệm nhìn tướng của mình thì cái bác giải bài toán lớp 3 không được (@VetMini ), thì làm sao mà xen vào lĩnh vực cao thủ VBA như này được bạn à,

tam888 · 3/5/18

hiénlinh197 đã viết:
Bạn
AutoReply
nhìn nhầm người rồi, "Nhìn mặt mà bắt hình dong". "nhìn mặt gửi vàng" đấy là câu nói của các cụ ngày xưa, Không biết bây giờ có còn đúng hay không? Nhưng theo kinh nghiệm nhìn tướng của mình thì cái bác giải bài toán lớp 3 không được (@VetMini ), thì làm sao mà xen vào lĩnh vực cao thủ VBA như này được bạn à,

Hình như bạn (hiénlinh197) là con cưng của Diễn đàn này hay sao?
Chủ đề nào cũng dài lê thê, thay đổi câu hỏi, đòi hỏi đủ điều, từ vô lý bài toán lớp 3 đến việc khích mạ người khác, vậy mà BQT vẫn dung dưỡng và để tồn tại, phải chăng đến lúc mạc rồi (?).

hiénlinh197 · 3/5/18

tam888 đã viết:
Hình như bạn (hiénlinh197) là con cưng của Diễn đàn này hay sao?
Chủ đề nào cũng dài lê thê, thay đổi câu hỏi, đòi hỏi đủ điều, từ vô lý bài toán lớp 3 đến việc khích mạ người khác, vậy mà BQT vẫn dung dưỡng và để tồn tại, phải chăng đến lúc mạc rồi (?).

Bạn @tam888 nhầm rồi, không ai là con cưng cả, Chân lý là chân lý bạn à, Một công thức làm ra phải có chứng minh thì mới gọi là công thức. Nếu không có chứng minh thì là suông. "Một dạng bài toán thì phải có nhiều kiểu". Bạn xem lại câu nói của bạn đi nhé!

hiénlinh197 · 5/5/18

Khó quá, nhờ các bạn sửa giúp theo file mình gửi kèm đã có 1 code ở đó.
Cảm ơn các bạn.

HieuCD · 5/5/18

hiénlinh197 đã viết:
Khó quá, nhờ các bạn sửa giúp theo file mình gửi kèm đã có 1 code ở đó.
Cảm ơn các bạn.

Chạy code

Mã:

Sub Rectangle1_Click()
  Dim Arr(), kq(), Rng(), i As Long, j As Long, k As Long, jMax As Long, key As String
  Rng = Array("L4:Z23", "L31:Z50") 'Nhap dia chi vào Rng
  For n = 0 To UBound(Rng)
    On Error Resume Next
    Arr = Sheet1.Range(Rng(n)).Value
    If Err.Number Then MsgBox ("Loi Dia Chi: " & Rng(n))
    ReDim kq(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            k = 0
            .RemoveAll
            For j = 1 To UBound(Arr, 2)
                key = CStr(Arr(i, j))
                If key <> "" Then
                    If Not .exists(key) Then
                        .Add key, ""
                        k = k + 1
                        kq(i, k) = key
                    End If
                End If
            Next j
            If jMax < k Then jMax = k 'Tính só cot ket qua
        Next i
    End With
    Sheet1.Range("B" & Range(Rng(n)).Row).Resize(UBound(kq, 1), 10).ClearContents
    Sheet1.Range("B" & Range(Rng(n)).Row).Resize(UBound(kq, 1), jMax).Value = kq
    On Error GoTo 0
  Next n
End Sub

♫ђöล♥ßล†♥†µ♫ · 5/5/18

hiénlinh197 đã viết:
Khó quá, nhờ các bạn sửa giúp theo file mình gửi kèm đã có 1 code ở đó.
Cảm ơn các bạn.

Em ăm trộm Code của anh HieuCD đưa vào Function. Kết quả được gắn vào ô B52 Sheet1. Anh kiểm tra thử
P/s: Nếu có lỗi trong quá trình chạy Code đều được bỏ qua. Như vậy cho hào phóng anh ạ

HieuCD · 5/5/18

♫ђöล♥ßล†♥†µ♫ đã viết:
Em ăm trộm Code của anh HieuCD đưa vào Function. Kết quả được gắn vào ô B52 Sheet1. Anh kiểm tra thử
P/s: Nếu có lỗi trong quá trình chạy Code đều được bỏ qua. Như vậy cho hào phóng anh ạ

Chỉnh Sub để Kết quả trả về đúng dòng của dữ liệu của từng mảng là Ok

hiénlinh197 · 5/5/18

HieuCD đã viết:

Chạy code

Mã:

Sub Rectangle1_Click()
  Dim Arr(), kq(), Rng(), i As Long, j As Long, k As Long, jMax As Long, key As String
  Rng = Array("L4:Z23", "L31:Z50") 'Nhap dia chi vào Rng
  For n = 0 To UBound(Rng)
    On Error Resume Next
    Arr = Sheet1.Range(Rng(n)).Value
    If Err.Number Then MsgBox ("Loi Dia Chi: " & Rng(n))
    ReDim kq(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    With CreateObject("Scripting.dictionary")
        For i = 1 To UBound(Arr, 1)
            k = 0
            .RemoveAll
            For j = 1 To UBound(Arr, 2)
                key = CStr(Arr(i, j))
                If key <> "" Then
                    If Not .exists(key) Then
                        .Add key, ""
                        k = k + 1
                        kq(i, k) = key
                    End If
                End If
            Next j
            If jMax < k Then jMax = k 'Tính só cot ket qua
        Next i
    End With
    Sheet1.Range("B" & Range(Rng(n)).Row).Resize(UBound(kq, 1), 10).ClearContents
    Sheet1.Range("B" & Range(Rng(n)).Row).Resize(UBound(kq, 1), jMax).Value = kq
    On Error GoTo 0
  Next n
End Sub

Tuyệt vời, quá tuyệt vời! Cảm ơn anh
HieuCD
rất nhiều nhiều. Code chuẩn không thể chỉnh. Cảm ơn anh, Chúc anh luôn luôn mạnh khỏe, công tác tốt và an lành, hạnh phúc. Chúc anh cuối tuần vui vẻ.

hiénlinh197 · 5/5/18

♫ђöล♥ßล†♥†µ♫ đã viết:
Em ăm trộm Code của anh HieuCD đưa vào Function. Kết quả được gắn vào ô B52 Sheet1. Anh kiểm tra thử
P/s: Nếu có lỗi trong quá trình chạy Code đều được bỏ qua. Như vậy cho hào phóng anh ạ

Cảm ơn bạn
♫ђöล♥ßล†♥†µ♫
đã rất nhiệt tình giúp đỡ. Code chạy cũng rất chuẩn.
Chúc
♫ђöล♥ßล†♥†µ♫
cuối tuần vui vẻ và hạnh phúc.

Sửa giúp code dồn số liệu (1 người xem)

Người dùng đang xem chủ đề này

Thành viên tiêu biểu

File đính kèm

Chuyên gia GPE

Thành viên tiêu biểu

Chuyên gia GPE

Thành viên tiêu biểu

File đính kèm

Chuyên gia GPE

Thành viên tiêu biểu

Chuyên gia GPE

Thành viên tiêu biểu

File đính kèm

Chuyên gia GPE

Thành viên gạo cội

Thành viên tiêu biểu

Thành viên tiêu biểu

|||||||||||||

File đính kèm

Thành viên gạo cội

Thành viên tiêu biểu

Huyền thoại GPE

Thành viên tiêu biểu

Thành viên tiêu biểu

|||||||||||||

Thành viên tiêu biểu

Huyền thoại GPE

Thành viên tiêu biểu

File đính kèm

|||||||||||||

File đính kèm

Thành viên tiêu biểu

Thành viên gạo cội

Thành viên tiêu biểu

Thành viên gạo cội

|||||||||||||

File đính kèm

Thành viên tiêu biểu

Thành viên gạo cội

Thành viên tiêu biểu

Thành viên tiêu biểu

Đang đi tìm hòn đá

Thành viên tiêu biểu

Trùm Nhiều Chuyện

Thành viên gạo cội

Đang đi tìm hòn đá

Thành viên tiêu biểu

Thành viên gạo cội

Thành viên tiêu biểu

Thành viên tiêu biểu

Thành viên tiêu biểu

Thành viên tích cực

Thành viên tiêu biểu

Thành viên tiêu biểu

File đính kèm

Chuyên gia GPE

Thành viên tiêu biểu

File đính kèm

Chuyên gia GPE

Thành viên tiêu biểu

Thành viên tiêu biểu

Thời gian đếm ngược.