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

[hiénlinh197]

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

 

[hiénlinh197]

Mỗi khi có vụ mới thì phải mô tả kỹ để người khác biết mình muốn gì. Rõ ràng là yêu cầu bây giờ khác yêu cầu ban đầu, nên là vấn đề mới, vậy phải mô tả lại từ đầu.

Tập tin phải có dữ liệu "biết nói". Nếu dữ liệu giả lập là 2, 3, 4, 5 và kết quả mong đợi cũng là 2, 3, 4 và 5 thì người khác có thể hiểu là lấy hết các số có trong dòng. Nếu dữ liệu giả lập là 2, 3, 4, 3, 5, 4, 2 mà kết quả mong đợi là 2, 3, 4 và 5 thì người khác sẽ hiểu là chỉ lấy các giá trị khác nhau từng đôi một. Dữ liệu thứ hai là dữ liệu "biết nói"

Hỏi cũng phải biết hỏi, phải suy nghĩ, để khỏi mất thời gian của người khác.

Bác cho tôi xin lại được không? Hôm qua tôi xem kịch hay mà bỏ 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]

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]

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]

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]

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]

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]

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

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

 

[♫ђöล♥ßล†♥†µ♫]

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]

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]

Chạy code

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]

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.