Một bài toán dò tìm và nối chuổi (1 người xem)

ndu96081631 · 19/8/10

Tôi thấy có 1 bạn nickname thuybytg hỏi như vầy:

thuybytg đã viết:
Lấy dữ liệu từ các dòng của một cột, ghép vào cột diễn giải

Tôi có một files gồm 2 sheet: DL và TH (xin xem thêm files đính kèm). Từ dữ liệu ở sheet DL tôi muốn tổng hợp và diễn giải cụ thể thành dữ liệu ở sheet TH thì phải làm như thế nào?
Nhờ các cao thủ giúp giùm!
(Lưu ý thêm: Có thể chèn them sheet hoặc các cột trung gian nhưng tốt nhất không dùng Macro).
Xin trân trọng cảm ơn.

Bài toán về dò tìm và nối chuổi dạng này rất hay và cũng rất khó! Tiếc rằng bạn ấy post bài sai box nên bị cho vào thùng rác
http://www.giaiphapexcel.com/forum/...ừ-các-dòng-của-một-cột-ghép-vào-cột-diễn-giải
Thấy tiếc quá nên mở topic mới, post lại cho bạn ấy!
Có điều bài này mà không dùng code VBA thì...

rollover79 · 19/8/10

ndu96081631 đã viết:
Tôi thấy có 1 bạn nickname thuybytg hỏi như vầy:
Bài toán về dò tìm và nối chuổi dạng này rất hay và cũng rất khó! Tiếc rằng bạn ấy post bài sai box nên bị cho vào thùng rác
http://www.giaiphapexcel.com/forum/...ừ-các-dòng-của-một-cột-ghép-vào-cột-diễn-giải
Thấy tiếc quá nên mở topic mới, post lại cho bạn ấy!
Có điều bài này mà không dùng code VBA thì...

Không dùng VBA nhưng có dùng cột tạm thì thôi có thể làm theo như file đính kèm
(Đây là giải theo điều kiện cột GV của Sheet được sắp xếp, nếu không sắp xếp thì phức tạp hơn chút)

ndu96081631 · 19/8/10

rollover79 đã viết:
Không dùng VBA nhưng có dùng cột tạm thì thôi có thể làm theo như file đính kèm
(Đây là giải theo điều kiện cột GV của Sheet được sắp xếp, nếu không sắp xếp thì phức tạp hơn chút)

Tuy tác giả không thích macro nhưng mình cũng xin đưa lên 1 code (ai thích thì xài)

PHP:

Function DienGiai(FVal, FindRng As Range, RestRng As Range) As String
  Dim i As Long, j As Long, Temp, Arr(), Dic1, Dic2
  Set Dic1 = CreateObject("Scripting.Dictionary")
  Set Dic2 = CreateObject("Scripting.Dictionary")
  For i = 1 To FindRng.Rows.Count
    If FindRng(i, 1) = FVal Then
      Temp = RestRng(i, 1)
      If Not Dic1.Exists(Temp) Then
        j = j + 1
        Dic1.Add Temp, 1
        Dic2.Add Temp, j
      Else
        Dic1.Item(Temp) = Dic1.Item(Temp) + 1
      End If
      ReDim Preserve Arr(1 To j)
      Arr(Dic2.Item(Temp)) = Temp & "(" & Dic1.Item(Temp) & ")"
    End If
  Next
  DienGiai = Join(Arr, ", ")
End Function

Không biết có chiêu nào khác nữa không (bạn rollover79 dùng code ra sao nếu giải quyết bằng VBA?)

rollover79 · 19/8/10

ndu96081631 đã viết:
Tuy tác giả không thích macro nhưng mình cũng xin đưa lên 1 code (ai thích thì xài)

PHP:

Function DienGiai(FVal, FindRng As Range, RestRng As Range) As String Dim i As Long, j As Long, Temp, Arr(), Dic1, Dic2 Set Dic1 = CreateObject("Scripting.Dictionary") Set Dic2 = CreateObject("Scripting.Dictionary") For i = 1 To FindRng.Rows.Count If FindRng(i, 1) = FVal Then Temp = RestRng(i, 1) If Not Dic1.Exists(Temp) Then j = j + 1 Dic1.Add Temp, 1 Dic2.Add Temp, j Else Dic1.Item(Temp) = Dic1.Item(Temp) + 1 End If ReDim Preserve Arr(1 To j) Arr(Dic2.Item(Temp)) = Temp & "(" & Dic1.Item(Temp) & ")" End If Next DienGiai = Join(Arr, ", ") End Function

Không biết có chiêu nào khác nữa không (bạn rollover79 dùng code ra sao nếu giải quyết bằng VBA?)

Cá nhân tôi vẫn thích tạo vùng tạm để giải quyết, còn với yêu cầu này mà dùng VBA thì có nhiều cách giải lắm,ví dụ tôi có thể dùng hoàn toàn các phép toán trên chuỗi để giải quyết bài toán này như sau

Mã:

Function DienGiai(FVal, FindRng As Range, RestRng As Range) As String
    Dim sRet As String, sTemp As String, iRun As Long, iPos As Long, iOpenPos As Long, iClosePos As Long
    For iRun = 1 To FindRng.Rows.Count
        If FindRng(iRun, 1) = FVal Then
            sTemp = RestRng(iRun, 1)
            iPos = InStr(1, sRet, vbBack & sTemp & vbBack)
            If iPos = 0 Then
                sRet = sRet & vbBack & sTemp & vbBack & "(1),"
            Else
                iOpenPos = InStr(iPos, sRet, "(")
                iClosePos = InStr(iOpenPos, sRet, ")")
                sRet = Left(sRet, iOpenPos) & (Mid(sRet, iOpenPos + 1, iClosePos - iOpenPos - 1) + 1) & Mid(sRet, iClosePos)
            End If
        End If
    Next
    DienGiai = Replace(Left(sRet, Len(sRet) - 1), vbBack, "")
End Function

ndu96081631 · 19/8/10

rollover79 đã viết:
Cá nhân tôi vẫn thích tạo vùng tạm để giải quyết, còn với yêu cầu này mà dùng VBA thì có nhiều cách giải lắm,ví dụ tôi có thể dùng hoàn toàn các phép toán trên chuỗi để giải quyết bài toán này như sau

Mã:

Function DienGiai(FVal, FindRng As Range, RestRng As Range) As String Dim sRet As String, sTemp As String, iRun As Long, iPos As Long, iOpenPos As Long, iClosePos As Long For iRun = 1 To FindRng.Rows.Count If FindRng(iRun, 1) = FVal Then sTemp = RestRng(iRun, 1) iPos = InStr(1, sRet, vbBack & sTemp & vbBack) If iPos = 0 Then sRet = sRet & vbBack & sTemp & vbBack & "(1)," Else iOpenPos = InStr(iPos, sRet, "(") iClosePos = InStr(iOpenPos, sRet, ")") sRet = Left(sRet, iOpenPos) & (Mid(sRet, iOpenPos + 1, iClosePos - iOpenPos - 1) + 1) & Mid(sRet, iClosePos) End If End If Next DienGiai = Replace(Left(sRet, Len(sRet) - 1), vbBack, "") End Function

Vì không dùng Dictionary Object để lọc duy nhất nên bạn đã dùng phép nối chuổi ---> Nhớ không lầm thì đây là TUYỆT CHIÊU của bạn rồi
Tôi cũng đã từng làm như vậy nhưng cảm thấy nó phức tạp quá nên không dám... "múa"
Hi... Hi...
(Sở dĩ tôi hỏi đích danh bạn là vì tôi đang tưởng tượng không biết bài này có thể dùng chiêu JavaScript gì gì đó hay không?)

ndu96081631 · 20/8/10

Có 1 bài nữa gần giống đây:

tutientrung · 20/8/10

MÌnh cũng có 1 bảng có yêu cầu như bài của bác NDU .Vậy nhờ các bạn tham gia giải quyết dùm nha. }}}}}

Hay bác NDU đưa ra cách giải quyết cho mọi người tham khảo trước đi. --=0

dat_butmuc · 20/8/10

tutientrung đã viết:
MÌnh cũng có 1 bảng có yêu cầu như bài của bác NDU .Vậy nhờ các bạn tham gia giải quyết dùm nha.
Hay bác NDU đưa ra cách giải quyết cho mọi người tham khảo trước đi.

Bài này thì ở đây:
http://www.giaiphapexcel.com/forum/...liệu-như-trong-bảng-Ví-dụ&p=260919#post260919

ndu96081631 · 20/8/10

dat_butmuc đã viết:
Bài này thì ở đây:
http://www.giaiphapexcel.com/forum/showthread.php?39297-Dùng-hàm-gì-để-lọc-dữ-liệu-như-trong-bảng-Ví-dụ&p=260919#post260919

Tôi từng thấy bài ấy bạn giải bằng PivotTable --> Rất hay!
Vấn đề là kết quả đâu có giống!
Bài này nếu dùng công thức thì chả biết thế nào ---> Cho phép lập trình luôn cũng là bài toán khó rồi
-------------

tutientrung đã viết:
MÌnh cũng có 1 bảng có yêu cầu như bài của bác NDU .Vậy nhờ các bạn tham gia giải quyết dùm nha.
Hay bác NDU đưa ra cách giải quyết cho mọi người tham khảo trước đi.

Bài này tôi đưa lên đây vì hy vọng có ai đó giải quyết nó bằng công thức (cho trường hợp tổng quát) ---> Còn giải pháp VBA thì tôi đã có rồi, gần giống với giải pháp tại bài 1:

PHP:

Sub Transfer(sRng1 As Range, sRng2 As Range, Target As Range)
  Dim sArr1, sArr2, i As Long, j As Long, iR As Long, iC As Long
  Dim Arr(1 To 60000, 1 To 200), Tmp1, Tmp2, Dic1, Dic2
  Set Dic1 = CreateObject("Scripting.Dictionary")
  Set Dic2 = CreateObject("Scripting.Dictionary")
  sArr1 = sRng1: sArr2 = sRng2
  For i = LBound(sArr1, 1) To UBound(sArr1, 1)
    For j = LBound(sArr1, 2) To UBound(sArr1, 2)
      If sArr1(i, j) <> "" Then
        Tmp1 = sArr1(i, j)
        Tmp2 = sArr2(i, j)
        If Not Dic1.Exists(Tmp1) Then
          iR = iR + 1
          Dic1.Add Tmp1, iR
          Dic2.Add Tmp1, 2
          Arr(iR, 1) = Tmp1
          Arr(iR, 2) = Tmp2
        Else
          Dic2.Item(Tmp1) = Dic2.Item(Tmp1) + 1
          Arr(Dic1.Item(Tmp1), Dic2.Item(Tmp1)) = Tmp2
        End If
        If iC < Dic2.Item(Tmp1) Then iC = Dic2.Item(Tmp1)
      End If
    Next
  Next
  Target.Resize(iR, iC).Value = Arr
End Sub

PHP:

Sub Main()
  Dim sRng1 As Range, sRng2 As Range, Target As Range
  Set sRng1 = Range("A3:A100")
  Set sRng2 = Range("C3:C100")
  Set Target = Range("G2")
  Transfer sRng1, sRng2, Target
End Sub

Dữ liệu nguồn bố trí theo dòng hay cột đều chơi tuốt

tutientrung · 20/8/10

Bấm cám ơn không thấy chưa đủ nên viết vài lời :Cám ơn bác NDU nha( em test trên file e thấy OK rồi ,file e cũng hơi nhiều dòng đấy) .Bữa giờ không giám post lên hỏi ,may nhờ có bác post dùm .Có bạn nào có cách khác không nhỉ...

dat_butmuc · 20/8/10

ndu96081631 đã viết:
Tôi từng thấy bài ấy bạn giải bằng PivotTable --> Rất hay!
Vấn đề là kết quả đâu có giống!
Bài này nếu dùng công thức thì chả biết thế nào ---> Cho phép lập trình luôn cũng là bài toán khó rồi
-------------

Bài này tôi đưa lên đây vì hy vọng có ai đó giải quyết nó bằng công thức (cho trường hợp tổng quát) ---> Còn giải pháp VBA thì tôi đã có rồi, gần giống với giải pháp tại bài 1:

Ấy, ấy - tôi không nói tới Pivot mà tôi đã làm (vì làm theo yêu cầu tác giả)
Cái tôi nói tới là công thức ấy, Bác concogia đã giải quyết bằng công thức tại đây nè (bài 2) : http://www.giaiphapexcel.com/forum/...liệu-như-trong-bảng-Ví-dụ&p=260911#post260911

Bác không đọc hết là phụ lòng Bác Cò già lắm đấy ... Hix

ndu96081631 · 20/8/10

dat_butmuc đã viết:
Ấy, ấy - tôi không nói tới Pivot mà tôi đã làm (vì làm theo yêu cầu tác giả)
Cái tôi nói tới là công thức ấy, Bác concogia đã giải quyết bằng công thức tại đây nè (bài 2) : http://www.giaiphapexcel.com/forum/...liệu-như-trong-bảng-Ví-dụ&p=260911#post260911

Thì bác concogia cũng đã nói:

concogia đã viết:
Bài này dữ liệu ít thì dùng công thức, nếu nhiều thì "chơi" VBA cho nhẹ nhàng nhé bạn
Làm bằng công thức thử xem sao

Dữ liệu nhiều mà công thức có mà... chết (nhất là khi dùng mảng)

huuthang_bd · 20/8/10

dat_butmuc đã viết:
Ấy, ấy - tôi không nói tới Pivot mà tôi đã làm (vì làm theo yêu cầu tác giả)
Cái tôi nói tới là công thức ấy, Bác concogia đã giải quyết bằng công thức tại đây nè (bài 2) : http://www.giaiphapexcel.com/forum/showthread.php?39297-Dùng-hàm-gì-để-lọc-dữ-liệu-như-trong-bảng-Ví-dụ&p=260911#post260911

Bác không đọc hết là phụ lòng Bác Cò già lắm đấy ... Hix

Nếu mà làm bằng công thức thì cách làm của bạn concogia cũng chưa ổn:
- Mã sản phẩm bạn ấy nhập bằng tay. Đúng lý ra phải đùng công thức để trích lọc duy nhất ra.
- Ở đây chỉ là ví dụ nên ký tự đầu tiên của mã đơn hàng là mã sản phẩm chứ thực thế thì không thể như vậy. Vì vậy, name hang như vậy là chưa ổn.

ThuNghi · 20/8/10

ndu96081631 đã viết:
Có 1 bài nữa gần giống đây:

View attachment 50831

Tôi thử dùng code theo java, học của RollOver và cách của NDU làm cho file TransferData trên, thấy chạy cũng ổn mà nhanh. Cũng là cách học hỏi về "Set objSC = CreateObject("MSScriptControl.ScriptControl")"
Nhưng không biết cách chuyển sang dùng UDF như của NDU.

PHP:

Public Function SortArray(Arr, Optional isText As Boolean = False, Optional isDESC As Boolean = False)
    Dim sCommand As String
    sCommand = "('" & Join(Arr, vbBack) & "').split('" & vbBack & "').sort("
    If isText Then
        sCommand = sCommand & ")"
    Else
        sCommand = sCommand & "function(a,b){return (a-b)})"
    End If
    If isDESC Then sCommand = sCommand & ".reverse()"
    sCommand = sCommand & ".join('" & vbBack & "')"
    Dim objSC
    Set objSC = CreateObject("MSScriptControl.ScriptControl")
    objSC.Language = "JavaScript"
    SortArray = Split(objSC.Eval(sCommand), vbBack)
End Function

Nên đành phải làm trong sub.
Vậy nhờ NDU và RollOver làm giúp:
1/ Gán UDF trên vào sub nhằm bỏ bớt các Array trung gian.
2/ Hướng dẫn nếu isText <> True thì nghĩa là gì.
Xin cám ơn. Code theo file

PHP:

Dim endR As Long, i As Long, s As Long, sStr As String
Dim Arr(), arrKQ(), arrSort()
Sub TaoArr()
Dim Dic As Object
With Sheets("Sheet1")
  endR = .Cells(65000, 3).End(xlUp).Row
  Arr = .Range(.Cells(3, 3), .Cells(endR, 3)).Value
End With
s = 0
sStr = ""
For i = 1 To UBound(Arr)
  If InStr(1, sStr, Arr(i, 1)) = 0 Then
    s = s + 1
    ReDim Preserve arrKQ(1 To s)
    arrKQ(s) = Arr(i, 1)
    sStr = sStr & Arr(i, 1)
  End If
Next i
End Sub
Sub TaoTH()
TaoArr
Dim isText As Boolean, isDESC As Boolean
Dim sCommand As String, ArrX, arrY(1 To 10000, 1 To 100)
isText = True
'isDESC = True 'true la giam dan
arrSort = arrKQ
sCommand = "('" & Join(arrSort, vbBack) & "').split('" & vbBack & "').sort("
If isText Then
    sCommand = sCommand & ")"
Else
    sCommand = sCommand & "function(a,b){return (a-b)})"
End If
If isDESC Then sCommand = sCommand & ".reverse()"
sCommand = sCommand & ".join('" & vbBack & "')"
Dim objSC
Set objSC = CreateObject("MSScriptControl.ScriptControl")
objSC.Language = "JavaScript"
ArrX = Split(objSC.Eval(sCommand), vbBack)
s = 1: k = 2
arrY(s, 1) = Left(ArrX(0), 1)
arrY(s, k) = ArrX(0)
For i = 1 To UBound(ArrX)
  If Left(ArrX(i), 1) <> Left(ArrX(i - 1), 1) Then
    s = s + 1
    k = 2
    arrY(s, 1) = Left(ArrX(i), 1)
    arrY(s, k) = ArrX(i)
  Else
    k = k + 1
    arrY(s, k) = ArrX(i)
  End If
Next i
Range("G18").Resize(s, k) = arrY
Erase Arr, arrKQ, arrSort, ArrX, arrY
End Sub

ndu96081631 · 20/8/10

ThuNghi đã viết:
2/ Hướng dẫn nếu isText <> True thì nghĩa là gì.

Vì sort bằng JavaScript có phân biệt dữ liệu là TEXT hoặc NUMBER đấy ThuNghi à!
Ngoài ra! Hàm của rollover79 chỉ hoạt động với mảng 1 chiều ---> Vì thế, với loại dữ liệu theo cột (A1:An) ta phải dùng TRANSPOSE để biến nó thành mảng 1 chiều trước khi dùng hàm
--------------
Nói thêm:
Sở dĩ code của tôi hơi chậm là vì cái Dim Arr(1 To 60000, 1 To 200)
sửa thành vầy sẽ nhanh ngay
Dim Arr()
...
ReDim Arr(1 To sRng1.Rows.Count, 1 To 100)

ThuNghi · 20/8/10

ndu96081631 đã viết:
Vì sort bằng JavaScript có phân biệt dữ liệu là TEXT hoặc NUMBER đấy ThuNghi à!
Ngoài ra! Hàm của rollover79 chỉ hoạt động với mảng 1 chiều ---> Vì thế, với loại dữ liệu theo cột (A1:An) ta phải dùng TRANSPOSE để biến nó thành mảng 1 chiều trước khi dùng hàm
--------------
Nói thêm:
Sở dĩ code của tôi hơi chậm là vì cái Dim Arr(1 To 60000, 1 To 200)
sửa thành vầy sẽ nhanh ngay
Dim Arr()
...
ReDim Arr(1 To sRng1.Rows.Count, 1 To 100)

ArrKQ trên là mảng ngang 1 chiều đó chớ. Vì TaoTH xử lý theo mảng ngang mà.
Khi TaoArr mình đã tách những mã trùng và gắn vào ArrKQ, đến phần sort lại gán tiếp arrSort = arrKQ nên thấy lạm dụng Arr quá.

ReDim Preserve arrKQ(1 To s)

Nhưng mà thử biến qua biến lại mà chả gán vào UDF được.
Thêm nữa, dùng Java chỉ sort và nếu thêm lấy duy nhất thì có vận dụng luôn được không. Và có thể bỏ cell trống?
Cám ơn đã quan tâm.

tutientrung · 20/8/10

ndu96081631 đã viết:
--------------
Nói thêm:
Sở dĩ code của tôi hơi chậm là vì cái Dim Arr(1 To 60000, 1 To 200)
sửa thành vầy sẽ nhanh ngay
Dim Arr()
...
ReDim Arr(1 To sRng1.Rows.Count, 1 To 100)

Để không làm mất thời gian hướng dẫn của bác NDU.Cụ thể là thay như thế nào cho chính xác (mình không rành code lắm).Bác NDU có thề cho xin file hoàn thiện nhất và chạy nhanh nhất được không vậy bác.Xin cámơn bác NDU và các bạn đã tham gia bài này rất nhiều.

ndu96081631 · 21/8/10

tutientrung đã viết:
Để không làm mất thời gian hướng dẫn của bác NDU.Cụ thể là thay như thế nào cho chính xác (mình không rành code lắm).Bác NDU có thề cho xin file hoàn thiện nhất và chạy nhanh nhất được không vậy bác.Xin cámơn bác NDU và các bạn đã tham gia bài này rất nhiều.

Sửa thành vầy:

PHP:

Sub Transfer(sRng1 As Range, sRng2 As Range, Target As Range)
  Dim sArr1, sArr2, i As Long, j As Long, iR As Long, iC As Long
  Dim Arr(), Tmp1, Tmp2, Dic1, Dic2
  Set Dic1 = CreateObject("Scripting.Dictionary")
  Set Dic2 = CreateObject("Scripting.Dictionary")
  sArr1 = sRng1: sArr2 = sRng2
  ReDim Arr(1 To sRng1.Rows.Count, 1 To 200)
  For i = LBound(sArr1, 1) To UBound(sArr1, 1)
    For j = LBound(sArr1, 2) To UBound(sArr1, 2)
      If sArr1(i, j) <> "" Then
        Tmp1 = sArr1(i, j)
        Tmp2 = sArr2(i, j)
        If Not Dic1.Exists(Tmp1) Then
          iR = iR + 1
          Dic1.Add Tmp1, iR
          Dic2.Add Tmp1, 2
          Arr(iR, 1) = Tmp1
          Arr(iR, 2) = Tmp2
        Else
          Dic2.Item(Tmp1) = Dic2.Item(Tmp1) + 1
          Arr(Dic1.Item(Tmp1), Dic2.Item(Tmp1)) = Tmp2
        End If
        If iC < Dic2.Item(Tmp1) Then iC = Dic2.Item(Tmp1)
      End If
    Next
  Next
  Target.Resize(iR, iC).Value = Arr
End Sub

Sub Main giữ nguyên

ThuNghi · 21/8/10

ndu96081631 đã viết:
Sửa thành vầy:
...
Sub Main giữ nguyên

Code này của NDU chưa lấy duy nhất MADOHANG, nếu yêu cầu của tác giả như vậy là OK. Còn không phải thêm 1 cái if nữa.
Cụ thể thêm 1 dòng A101 ...

filobo · 24/8/10

E có bài tập thế này, các bác giúp giùm
sheet 1 có bảng quy ước:
loại a loại b loại c loại d
10 3 20 100
12 4 22 110
14 5 24 120
16 6 26 130
18 7 28 140

qua sheet2
cell a1 em gõ loại a
cell b1 em gõ 13
làm sao để cell c1 có kết quả là: loại a-14
(lấy giá trị bằng hoặc lớn hơn nó, ví dụ 13 thì phải lấy 13 hoặc 14 nhưng do không có quy ước loại 13 nên phải lấy 14, hoặc 15 thì phải lấy thành 16)
Thanhks...s các bác!

phihndhsp · 18/10/11

Có bài này hao hao giống như vậy, nhờ các cao thủ chỉ giúp dùm

ndu96081631 · 19/10/11

phihndhsp đã viết:
Có bài này hao hao giống như vậy, nhờ các cao thủ chỉ giúp dùm

Nhập liệu không chuẩn chỉ tổ gây khó khăn thôi
Xem hình:

Nếu chuyển được cách bố trí dữ liệu như tôi nói trong hình thì mọi chuyển xem như đã được giải quyết

phihndhsp · 19/10/11

Dạ bài dạng này của thầy em tham khảo rồi em cũng có hướng theo đó, nếu người ta chịu cách bố trí đó thì khoẻ còn không thì hơi mệt một tí thầy à

ndu96081631 · 19/10/11

phihndhsp đã viết:
Dạ bài dạng này của thầy em tham khảo rồi em cũng có hướng theo đó, nếu người ta chịu cách bố trí đó thì khoẻ còn không thì hơi mệt một tí thầy à

Họ không chịu nghe là việc của họ... cuối cùng, nếu muốn xử lý, ta tự mình chuyển sang cơ sở dữ liệu chuẩn trước vậy

Tường_Vi · 30/11/11

ndu96081631 đã viết:
Có 1 bài nữa gần giống đây:

View attachment 50831

Mình có thể dùng UDF để làm dạng trên không?

Tường_Vi · 7/12/11

Xin lỗi em chưa xem bài 3#
Đã tìm thấy yêu cầu

597335 · 8/3/12

PHP:

Sub Transfer(sRng1 As Range, sRng2 As Range, Target As Range)
  Dim sArr1, sArr2, i As Long, j As Long, iR As Long, iC As Long
  Dim Arr(1 To 60000, 1 To 200), Tmp1, Tmp2, Dic1, Dic2
  Set Dic1 = CreateObject("Scripting.Dictionary")
  Set Dic2 = CreateObject("Scripting.Dictionary")
  sArr1 = sRng1: sArr2 = sRng2
  For i = LBound(sArr1, 1) To UBound(sArr1, 1)
    For j = LBound(sArr1, 2) To UBound(sArr1, 2)
      If sArr1(i, j) <> "" Then
        Tmp1 = sArr1(i, j)
        Tmp2 = sArr2(i, j)
        If Not Dic1.Exists(Tmp1) Then
          iR = iR + 1
          Dic1.Add Tmp1, iR
          Dic2.Add Tmp1, 2
          Arr(iR, 1) = Tmp1
          Arr(iR, 2) = Tmp2
        Else
          Dic2.Item(Tmp1) = Dic2.Item(Tmp1) + 1
          Arr(Dic1.Item(Tmp1), Dic2.Item(Tmp1)) = Tmp2
        End If
        If iC < Dic2.Item(Tmp1) Then iC = Dic2.Item(Tmp1)
      End If
    Next
  Next
  Target.Resize(iR, iC).Value = Arr
End Sub

PHP:

Sub Main()
  Dim sRng1 As Range, sRng2 As Range, Target As Range
  Set sRng1 = Range("A3:A100")
  Set sRng2 = Range("C3:C100")
  Set Target = Range("G2")
  Transfer sRng1, sRng2, Target
End Sub

Thưa thày sao lại cần dòng

PHP:

Transfer sRng1, sRng2, Target

có tác dụng gì ah, vì các dòng trên nó đã phản ánh vùng của sRng1, sRng2, Target rồi mà, hay là phải có nó thì 2 Sub mới Link với nhau (mới chịu phối hợp, làm việc cùng nhau)?

kyo · 8/3/12

597335 đã viết:

PHP:

Sub Transfer(sRng1 As Range, sRng2 As Range, Target As Range)
  Dim sArr1, sArr2, i As Long, j As Long, iR As Long, iC As Long
  Dim Arr(1 To 60000, 1 To 200), Tmp1, Tmp2, Dic1, Dic2
  Set Dic1 = CreateObject("Scripting.Dictionary")
  Set Dic2 = CreateObject("Scripting.Dictionary")
  sArr1 = sRng1: sArr2 = sRng2
  For i = LBound(sArr1, 1) To UBound(sArr1, 1)
    For j = LBound(sArr1, 2) To UBound(sArr1, 2)
      If sArr1(i, j) <> "" Then
        Tmp1 = sArr1(i, j)
        Tmp2 = sArr2(i, j)
        If Not Dic1.Exists(Tmp1) Then
          iR = iR + 1
          Dic1.Add Tmp1, iR
          Dic2.Add Tmp1, 2
          Arr(iR, 1) = Tmp1
          Arr(iR, 2) = Tmp2
        Else
          Dic2.Item(Tmp1) = Dic2.Item(Tmp1) + 1
          Arr(Dic1.Item(Tmp1), Dic2.Item(Tmp1)) = Tmp2
        End If
        If iC < Dic2.Item(Tmp1) Then iC = Dic2.Item(Tmp1)
      End If
    Next
  Next
  Target.Resize(iR, iC).Value = Arr
End Sub

PHP:

Sub Main()
  Dim sRng1 As Range, sRng2 As Range, Target As Range
  Set sRng1 = Range("A3:A100")
  Set sRng2 = Range("C3:C100")
  Set Target = Range("G2")
  Transfer sRng1, sRng2, Target
End Sub

Thưa thày sao lại cần dòng

PHP:

Transfer sRng1, sRng2, Target

có tác dụng gì ah, vì các dòng trên nó đã phản ánh vùng của sRng1, sRng2, Target rồi mà, hay là phải có nó thì 2 Sub mới Link với nhau (mới chịu phối hợp, làm việc cùng nhau)?

Sub Transfer được viết dưới dạng tổng quát và Sub Main chính là sub chính để chạy. Khi bạn chạy sub Main, nó sẽ nạp giá trị cho sRng1, sRng2, Target rồi nó sẽ gọi sub Transfer và truyền tham số vào nó.
Bạn muốn hiểu thêm thì bạn chạy thử sub Transfer xem có chạy được không là biết, rồi bạn thử chạy từ từ sub Main bằng F8 xem cách nó liên kết với nhau thế nào.

ndu96081631 · 8/3/12

597335 đã viết:
Thưa thày sao lại cần dòng

PHP:

Transfer sRng1, sRng2, Target

có tác dụng gì ah, vì các dòng trên nó đã phản ánh vùng của sRng1, sRng2, Target rồi mà, hay là phải có nó thì 2 Sub mới Link với nhau (mới chịu phối hợp, làm việc cùng nhau)?

Nếu cảm thấy không cần thì bạn có thể xóa bớt rồi chạy code xem nó "ra" cái gì?
Ẹc... Ẹc...
Cũng giống như ta nói rằng: Muốn xài hàm COUNTIF thì phải có vùng dữ liệu (Range) và điều kiện (Criteria)
Giờ bạn đã gõ dữ liệu vào 1 vùng nó đó rồi (tưc đã có Range) và cũng đã gõ điều kiện vào 1 cell nào đó rồi (tức đã có Criteria)... Vậy đến đây rồi.. thôi à? Hổng gọi hàm COUNTIF bằng cách đưa vùng dữ liệu và điều kiện vừa gõ vào thì nó "ra" bằng cách nào đây?
Theo ví dụ minh họa trên, bạn có thể mường tượng Sub Transfer như hàm COUNTIF còn sRng1, sRng2, Target là các đối số của nó ---> Khi đã có đối số rồi thì bạn phải gọi hàm chứ (bằng dòng lệnh Transfer sRng1, sRng2, Target)... Hổng gọi lấy cái giống gì để ra kết quả

597335 · 8/3/12

Bài này hay quá, Item(Dic1) chạy đánh dấu theo chiều dọc, Item(Dic2) chạy đánh dấu theo chiều ngang
iR sẽ được xác định dựa vào điều kiện Dictionary, tuy vậy iC thì cận trên của nó xác định ở đâu nhỉ?

Em định sửa thành như thế này thì "tèo" nhưng chưa tìm ra nguyên nhân, mong các thày chỉ cho

PHP:

Sub Transfer(sRng1 As Range, sRng2 As Range, Target As Range)
    Dim sArr1, sArr2, i As Long, iR As Long, iC As Long
    Dim Arr(1 To 60000, 1 To 200), Tmp1, Tmp2, Dic1, Dic2
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Set Dic2 = CreateObject("Scripting.Dictionary")
    sArr1 = sRng1: sArr2 = sRng2
    For i = LBound(sArr1, 1) To UBound(sArr1, 1)
        If sArr1(i, 1) <> "" Then
            Tmp1 = sArr1(i, 1)
            Tmp2 = sArr2(i, 1)
            If Not Dic1.Exists(Tmp1) Then
                iR = iR + 1
                Dic1.Add Tmp1, iR
                Dic2.Add Tmp1, 2
                Arr(iR, 1) = Tmp1
                Arr(iR, 2) = Tmp2
            Else
                Dic2.Item(Tmp1) = Dic2.Item(Tmp1) + 1
                Arr(Dic1.Item(Tmp1), Dic2.Item(Tmp1)) = Tmp2
            End If
            If iC = 1 Then iC = Dic2.Item(Tmp1)
        End If
    Next
    Target.Resize(iR, iC).Value = Arr
End Sub

PHP:

Sub Main()
    Dim sRng1 As Range, sRng2 As Range, Target As Range
    Set sRng1 = Range("A3:A100")
    Set sRng2 = Range("C3:C100")
    Set Target = Range("G2")
    Transfer sRng1, sRng2, Target
End Sub

--------
----> Nghĩa là hầu như bài nào mà đầu ra bố trí theo kiểu 2 chiều ngang, dọc của hình chữ nhật chắc là phải dùng 2 Dictionary?

ndu96081631 · 8/3/12

597335 đã viết:
Bài này hay quá, Item(Dic1) chạy đánh dấu theo chiều dọc, Item(Dic2) chạy đánh dấu theo chiều ngang
iR sẽ được xác định dựa vào điều kiện Dictionary, tuy vậy iC thì cận trên của nó xác định ở đâu nhỉ?

Em định sửa thành như thế này thì "tèo" nhưng chưa tìm ra nguyên nhân, mong các thày chỉ cho

PHP:

Sub Transfer(sRng1 As Range, sRng2 As Range, Target As Range) Dim sArr1, sArr2, i As Long, iR As Long, iC As Long Dim Arr(1 To 60000, 1 To 200), Tmp1, Tmp2, Dic1, Dic2 Set Dic1 = CreateObject("Scripting.Dictionary") Set Dic2 = CreateObject("Scripting.Dictionary") sArr1 = sRng1: sArr2 = sRng2 For i = LBound(sArr1, 1) To UBound(sArr1, 1) If sArr1(i, 1) <> "" Then Tmp1 = sArr1(i, 1) Tmp2 = sArr2(i, 1) If Not Dic1.Exists(Tmp1) Then iR = iR + 1 Dic1.Add Tmp1, iR Dic2.Add Tmp1, 2 Arr(iR, 1) = Tmp1 Arr(iR, 2) = Tmp2 Else Dic2.Item(Tmp1) = Dic2.Item(Tmp1) + 1 Arr(Dic1.Item(Tmp1), Dic2.Item(Tmp1)) = Tmp2 End If If iC = 1 Then iC = Dic2.Item(Tmp1) End If Next Target.Resize(iR, iC).Value = Arr End Sub

PHP:

Sub Main() Dim sRng1 As Range, sRng2 As Range, Target As Range Set sRng1 = Range("A3:A100") Set sRng2 = Range("C3:C100") Set Target = Range("G2") Transfer sRng1, sRng2, Target End Sub

--------
----> Nghĩa là hầu như bài nào mà đầu ra bố trí theo kiểu 2 chiều ngang, dọc của hình chữ nhật chắc là phải dùng 2 Dictionary?

Người ta xác định "độ rộng" lớn nhất của Arr bằng dòng này:
If iC < Dic2.Item(Tmp1) Then iC = Dic2.Item(Tmp1)
Tức cứ đem iC so sanh với Dic2.Item(Tmp1), nếu nhỏ hơn thì gán Dic2.Item(Tmp1) vào iC ---> Dẫn đến iC sẽ là số lớn nhất
Còn bạn thì lại ghi:
If iC = 1 Then iC = Dic2.Item(Tmp1) ----> Từ đầu đến cuối, iC có khi nào bằng 1 đâu nên iC cũng sẽ không bao giờ = Dic2.Item(Tmp1)
Mà cho dù iC có = Dic2.Item(Tmp1) thì cũng chưa chắc iC sẽ là số lớn nhất... Dẫn đến khi trích ra sẽ bị thiếu dữ liệu

597335 · 9/3/12

Em hiểu rồi ah, nhầm lẫn cơ bản quá, bởi không để ý đến dòng Arr(iR,1)=Tmp1 nên em cứ tự hỏi cột đầu tiên của Arr được xác định bởi đâu, cảm ơn thày Ndu rất nhiều.

iC nó chỉ là phần mở rộng thêm thôi chứ nó không phải là độ rộng của Arr (không bao gồm cột 1)

ndu96081631 · 9/3/12

597335 đã viết:
Em hiểu rồi ah, nhầm lẫn cơ bản quá, bởi không để ý đến dòng Arr(iR,1)=Tmp1 nên em cứ tự hỏi cột đầu tiên của Arr được xác định bởi đâu, cảm ơn thày Ndu rất nhiều.

iC nó chỉ là phần mở rộng thêm thôi chứ nó không phải là độ rộng của Arr (không bao gồm cột 1)

Nhân đây, bạn thử nghiên cứu xem có cách nào chỉ dùng 1 biến Dic mà vẫn làm được bài này không?
Ẹc... Ẹc...
(lại thêm 1 người nữa tiến bộ nhanh trong lĩnh vực lập trình đây... Cố lên..)

ThuNghi · 9/3/12

ndu96081631 đã viết:
Nhân đây, bạn thử nghiên cứu xem có cách nào chỉ dùng 1 biến Dic mà vẫn làm được bài này không?
Ẹc... Ẹc...
(lại thêm 1 người nữa tiến bộ nhanh trong lĩnh vực lập trình đây... Cố lên..)

Vấn đề là chịu nghiên cứu, chịu "vọc". Có thầy như NDU thì không tiến bộ mới lạ.
Rất cám ơn NDU về Dic. Mình là 1 trong những người học hỏi đâu tiên về Dic từ NDU đó.

597335 · 9/3/12

Em chưa có kinh nghiệm lắm, đôi khi viết xong Code kiểm soát đúng sai vẫn còn hạn chế, em làm thế này cũng chạy nhưng kết quả không đúng, rất mong được thày và mọi người chỉ cho em chỗ sai

PHP:

Sub Transfer(sRng1 As Range, sRng2 As Range, Target As Range)
    Dim sArr1, sArr2, Arr, Dic1, Dic2, i As Long, iR As Long, iC As Long, Tmp1, Tmp2
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Set Dic2 = CreateObject("Scripting.Dictionary")
    sArr1 = sRng1
    sArr2 = sRng2
    ReDim Preserve Arr(1 To UBound(sArr1, 1), 1 To 100)
    For i = 1 To UBound(sArr1, 1)
        If sArr1(i, 1) <> "" And Not Dic1.Exists(sArr1(i, 1)) Then
            Tmp1 = sArr1(i, 1)
            Tmp2 = sArr2(i, 1)
            iR = iR + 1
            Dic1.Add Tmp1, iR
            Dic2.Add Tmp1, 2
            Arr(iR, 1) = Tmp1
            Arr(iR, 2) = Tmp2
        Else
            Dic2.Item(Tmp1) = Dic2.Item(Tmp1) + 1
            Arr(iR, Dic2.Item(Tmp1)) = Tmp2
        End If
        If iC < Dic2.Item(Tmp1) Then iC = Dic2.Item(Tmp1)
    Next
    Target.Resize(iR, iC).Value = Arr
End Sub

PHP:

Sub Main()
    Dim sRng1 As Range, sRng2 As Range, Target As Range
    Set sRng1 = Range("A3:A100")
    Set sRng2 = Range("C3:C100")
    Set Target = Range("G2")
    Transfer sRng1, sRng2, Target
End Sub

ndu96081631 · 9/3/12

597335 đã viết:

Em chưa có kinh nghiệm lắm, đôi khi viết xong Code kiểm soát đúng sai vẫn còn hạn chế, em làm thế này cũng chạy nhưng kết quả không đúng, rất mong được thày và mọi người chỉ cho em chỗ sai

PHP:

Sub Transfer(sRng1 As Range, sRng2 As Range, Target As Range)
    Dim sArr1, sArr2, Arr, Dic1, Dic2, i As Long, iR As Long, iC As Long, Tmp1, Tmp2
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Set Dic2 = CreateObject("Scripting.Dictionary")
    sArr1 = sRng1
    sArr2 = sRng2
    ReDim Preserve Arr(1 To UBound(sArr1, 1), 1 To 100)
    For i = 1 To UBound(sArr1, 1)
        If sArr1(i, 1) <> "" And Not Dic1.Exists(sArr1(i, 1)) Then
            Tmp1 = sArr1(i, 1)
            Tmp2 = sArr2(i, 1)
            iR = iR + 1
            Dic1.Add Tmp1, iR
            Dic2.Add Tmp1, 2
            Arr(iR, 1) = Tmp1
            Arr(iR, 2) = Tmp2
        Else
            Dic2.Item(Tmp1) = Dic2.Item(Tmp1) + 1
            Arr(iR, Dic2.Item(Tmp1)) = Tmp2
        End If
        If iC < Dic2.Item(Tmp1) Then iC = Dic2.Item(Tmp1)
    Next
    Target.Resize(iR, iC).Value = Arr
End Sub

]

Sai nhiều chổ quá! Code đúng là:

Mã:

Sub Transfer(sRng1 As Range, sRng2 As Range, Target As Range)
  Dim sArr1, sArr2, Arr(), Dic1, Dic2, i As Long, iR As Long, iC As Long, Tmp1, Tmp2
  Set Dic1 = CreateObject("Scripting.Dictionary")
  Set Dic2 = CreateObject("Scripting.Dictionary")
  sArr1 = sRng1
  sArr2 = sRng2
[COLOR=#ff0000]  ReDim Arr(1 To UBound(sArr1, 1), 1 To 100)[/COLOR]
  For i = 1 To UBound(sArr1, 1)
    [COLOR=#ff0000]If sArr1(i, 1) <> "" Then
      Tmp1 = sArr1(i, 1)
      Tmp2 = sArr2(i, 1)
      If Not Dic1.Exists(sArr1(i, 1)) Then[/COLOR]
        iR = iR + 1
        Dic1.Add Tmp1, iR
        Dic2.Add Tmp1, 2
        Arr(iR, 1) = Tmp1
        Arr(iR, 2) = Tmp2
      Else
        Dic2.Item(Tmp1) = Dic2.Item(Tmp1) + 1
        Arr([COLOR=#ff0000]Dic1.Item(Tmp1)[/COLOR], Dic2.Item(Tmp1)) = Tmp2
      End If
      If iC < Dic2.Item(Tmp1) Then iC = Dic2.Item(Tmp1)
    End If
  Next
 [COLOR=#ff0000] If iR Then [/COLOR]Target.Resize(iR, iC).Value = Arr
End Sub

Chú ý những chổ tô đỏ rồi so sánh với code của bạn

597335 · 9/3/12

Không có thày chỉ bảo chắc em không thể tự tìm chỗ sai được, từ sáng làm đi làm lại cứ nghĩ tại sao thuật toán đúng mà kết quả lại sai, nguyên nhân nhận thức sai ở 2 điểm:

1) Không nên dùng

PHP:

If sArr1(i, 1) <> "" And Not Dic1.Exists(sArr1(i, 1)) Then
            Tmp1 = sArr1(i, 1)
            Tmp2 = sArr2(i, 1)

mà phải là thế này mới chuẩn

PHP:

If sArr1(i, 1) <> "" Then
            Tmp1 = sArr1(i, 1)
            Tmp2 = sArr2(i, 1)
            If Not Dic1.Exists(sArr1(i, 1)) Then
........

---> Dùng gộp nhiều lúc nguy hiểm quá ----> đa số trường hợp viết gộp là đúng, một số trường hợp cá biệt cần tách ra làm 2 câu lệnh.

2) Quan niệm nhầm iR và Dic1.Item(Tmp1) nó là 1, tưởng viết thế cho gọn; nhưng nó chỉ bằng nhau trong trường hợp Not Dic.Exists thôi, trường hợp còn lại (Else) thì nó độc lập nhau.

Từ hôm qua em học được ở thày được rất nhiều kiến thức, cảm ơn thày rất nhiều.

ndu96081631 · 9/3/12

597335 đã viết:
---> Dùng gộp nhiều lúc nguy hiểm quá ----> đa số trường hợp viết gộp là đúng, một số trường hợp cá biệt cần tách ra làm 2 câu lệnh.

2) Quan niệm nhầm iR và Dic1.Item(Tmp1) nó là 1, tưởng viết thế cho gọn; nhưng nó chỉ bằng nhau trong trường hợp Not Dic.Exists thôi, trường hợp còn lại (Else) thì nó độc lập nhau.

Từ hôm qua em học được ở thày được rất nhiều kiến thức, cảm ơn thày rất nhiều.

Phân tích được chổ sai là bạn quá giỏi rồi còn gì
Bảo đảm 1 năm sau, GPE sẽ có thêm 1 đại cao thủ là.. bạn (nếu như bạn vẫn chăm chỉ nghiên cứu như bây giờ)
Ẹc... Ẹc...

597335 · 9/3/12

Thưa thày Ndu, bài này có thể dùng 1 Dic làm ra được không ah, em nghĩ làm mãi chưa có kết quả , nếu sửa thành thế này thì thực ra kết quả vẫn đúng, nhưng trên cùng 1 hàng kết quả ra nó không liên tục,

PHP:

Sub Transfer(sRng1 As Range, sRng2 As Range, Target As Range)
  Dim sArr1, sArr2, Arr(), Dic1, Dic2, i As Long, iR As Long, iC As Long, Tmp1, Tmp2, j As Long
  Set Dic1 = CreateObject("Scripting.Dictionary")
  Set Dic2 = CreateObject("Scripting.Dictionary")
  sArr1 = sRng1
  sArr2 = sRng2
  ReDim Arr(1 To UBound(sArr1, 1), 1 To 100)
  For i = 1 To UBound(sArr1, 1)
    If sArr1(i, 1) <> "" Then
      Tmp1 = sArr1(i, 1)
      Tmp2 = sArr2(i, 1)
      If Not Dic1.Exists(sArr1(i, 1)) Then
        iR = iR + 1
        Dic1.Add Tmp1, iR
        j = 2
        Arr(iR, 1) = Tmp1
        Arr(iR, j) = Tmp2
      Else
        j = j + 1
        Arr(Dic1.Item(Tmp1), j) = Tmp2
      End If
      If iC < j Then iC = j
    End If
  Next
  If iR Then Target.Resize(iR, iC).Value = Arr
End Sub
Sub Main()
  Dim sRng1 As Range, sRng2 As Range, Target As Range
  Set sRng1 = Range("A3:A100")
  Set sRng2 = Range("C3:C100")
  Set Target = Range("G2")
  Transfer sRng1, sRng2, Target
End Sub

---> như vậy coi như chưa đạt yêu cầu
Rất mong thày làm giúp cách chỉ có 1 Dic để em có điều kiện học hỏi

ndu96081631 · 9/3/12

597335 đã viết:
Thưa thày Ndu, bài này có thể dùng 1 Dic làm ra được không ah, em nghĩ làm mãi chưa có kết quả , nếu sửa thành thế này thì thực ra kết quả vẫn đúng, nhưng trên cùng 1 hàng kết quả ra nó không liên tục,

---> như vậy coi như chưa đạt yêu cầu
Rất mong thày làm giúp cách chỉ có 1 Dic để em có điều kiện học hỏi

Để ý code gốc, ta có Item của Dic1 lưu vị trí dòng và Item của Dic2 lưu vị trí cột
Giờ nếu bỏ bớt Dic2 thì bạn phải tìm "chổ khác" mà lưu vị trí cột thôi (là 1 mảng tạm chẳng hạn)
Tiếp tục nghiên cứu đi
Ẹc... Ẹc...

Một bài toán dò tìm và nối chuổi (1 người xem)

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

Huyền thoại GPE

File đính kèm

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

File đính kèm

Huyền thoại GPE

File đính kèm

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

Huyền thoại GPE

Huyền thoại GPE

File đính kèm

Thành viên hoạt động

weitə r ə'pɔn prɔvidəns

Huyền thoại GPE

File đính kèm

Thành viên hoạt động

weitə r ə'pɔn prɔvidəns

Huyền thoại GPE

Chuyên gia GPE

Hãy cho rồi sẽ nhận!

File đính kèm

Huyền thoại GPE

Hãy cho rồi sẽ nhận!

Thành viên hoạt động

Huyền thoại GPE

Hãy cho rồi sẽ nhận!

Thành viên mới

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

File đính kèm

Huyền thoại GPE

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

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 hoạt động

File đính kèm

Nguyễn Khắc Duy

Huyền thoại GPE

Thành viên hoạt động

Huyền thoại GPE

Thành viên hoạt động

Huyền thoại GPE

Hãy cho rồi sẽ nhận!

Thành viên hoạt động

Huyền thoại GPE

Thành viên hoạt động

Huyền thoại GPE

Thành viên hoạt động

Huyền thoại GPE

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