Một bài toán dò tìm và nối chuổi (2 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!

Một bài toán dò tìm và nối chuổi (2 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

Đếm ngược thời gian