Ghép những số bên CELL 1 sang những CELL bên cạnh

[tunhantam]

Vì mình muốn mỗi lập cập nhật dữ liệu vào B & C sẽ có đáp án bên E:AN

 

[Quang_Hải]

Chỉ là bài toán tổ hợp thôi mà Quang Hải (đâu phải nội suy gì chứ)
Ví dụ:
- Đầu vào là ABC
- Kết quả ghép là: AA, AB, AC, BA, BB, BC, CA, CB, CC
- Trong dảy kết quả trên, nếu có trùng thì loại bỏ (unique)
Vậy thôi

Em biết thuật toán của mình chưa đủ để xơi bài này mà anh gọi em lên trả bài. Cũng ác thiêt đó. Nếu trúng thì tốt, nếu tác giả la lên chưa trúng thì anh hỗ trợ sửa giúp em nha.

Sub test()
Dim chuoi As String, kq(1 To 10000), i As Long, j As Long, tam As Variant, kqtam As Variant
chuoi = [D2] & [E2] & [F2]
With CreateObject("vbscript.regexp")
   .Global = True
   .Pattern = "\B"
   tam = .Replace(chuoi, ",")
End With
kqtam = Split(tam, ",")
With CreateObject("scripting.dictionary")
   For i = 0 To UBound(kqtam)
      For j = 0 To UBound(kqtam)
         If Not .exists(kqtam(i) & kqtam(j)) Then .Add kqtam(i) & kqtam(j), ""
      Next
   Next
   [H3].Resize(, .Count).NumberFormat = "@"
   [H3].Resize(, .Count) = .keys
End With
End Sub

 

[tunhantam]

Em biết thuật toán của mình chưa đủ để xơi bài này mà anh gọi em lên trả bài. Cũng ác thiêt đó. Nếu trúng thì tốt, nếu tác giả la lên chưa trúng thì anh hỗ trợ sửa giúp em nha.

Sub test()
Dim chuoi As String, kq(1 To 10000), i As Long, j As Long, tam As Variant, kqtam As Variant
chuoi = [D2] & [E2] & [F2]
With CreateObject("vbscript.regexp")
   .Global = True
   .Pattern = "\B"
   tam = .Replace(chuoi, ",")
End With
kqtam = Split(tam, ",")
With CreateObject("scripting.dictionary")
   For i = 0 To UBound(kqtam)
      For j = 0 To UBound(kqtam)
         If Not .exists(kqtam(i) & kqtam(j)) Then .Add kqtam(i) & kqtam(j), ""
      Next
   Next
   [H3].Resize(, .Count).NumberFormat = "@"
   [H3].Resize(, .Count) = .keys
End With
End Sub

Dạ cảm ơn bác đã quan tâm. Em đã load file bác về nhưng em không thấy có Hàm nào cả

 

[Quang_Hải]

Dạ cảm ơn bác đã quan tâm. Em đã load file bác về nhưng em không thấy có Hàm nào cả

Thì bài 17 là xài hàm đó, bài mình viêt bằng code mà hàm gì chứ. Nghiên cưu cách chay code trong file nhé. Nếu kết quả chưa trúng thì thế nào cũng có người hỗ trợ vì mình đã khởi động phương án cho bài toán của bạn rồi.

 

[dhn46]

Cảm ơn bác nhiều, nhưng em đọc file của bác hình như không hiểu ạ. Em cũng không biết cách chuyển sao cho (Đáp án từ cột dọc sang cột ngang) Híc.
Tại em mù tịt về nó nên mới vào hỏi ạ.
Thanks bác nhiều.

Mục đích của bạn là làm sao tách được ra các tổ hợp, vậy tôi để dang cột bạn chỉ cần thay các giá trị vào dữ liệu là có kết quả, công thức thì kéo sang bên, nếu muốn sang mảng ngang thì bạn copy > Paste special > chọn Value + Transpose là được.
Thân!

 

[hoamattroicoi]

Chỉ là bài toán tổ hợp thôi mà Quang Hải (đâu phải nội suy gì chứ)
Ví dụ:
- Đầu vào là ABC
- Kết quả ghép là: AA, AB, AC, BA, BB, BC, CA, CB, CC
- Trong dảy kết quả trên, nếu có trùng thì loại bỏ (unique)
Vậy thôi

Theo như sư phụ mô tả thì đây là bài toán chỉnh hợp chứ nhỉ? Cụ thể là chỉnh hợp lặp chập 2 của 3 phần tử, số phần tử tạo ra chính là 3^2 = 9 phần tử. Nếu là ABCD thì kết quả sẽ là 4^2 = 16 phần tử.

Thuật toán có phải thế này ạ:
- Dùng MID để tách ABC thành 3 phần tử A,B,C nạp vào 2 mảng Arr1(A,B,C) và Arr2(A,B,C)
- Dùng 2 vòng FOR lồng nhau để quét qua các ký tự này và ghép lần lượt chúng lại.

Em cũng chỉ dám nghĩ chứ cũng chưa hình dung ghép được thì nạp vào DIC thế nào, hic hic

 

[Ba Tê]

Các bác xem lại giúp em file em mới gửi lên.

Chọn ô C2 hoặc C3 (hoặc ô nào muốn tách) rồi bấm nút. Cái vụ tô màu chưa tính.

Public Sub GPE()
Dim Rng As Range, Arr(), I As Long, J As Long, L As Long, K As Long, Dic As Object, Tem As Variant
Set Dic = CreateObject("Scripting.Dictionary")
Set Rng = Selection
ReDim Arr(1 To 1, 1 To Len(Rng) ^ 2)
L = Len(Rng)
For I = 1 To L
    If Mid(Rng, I, 1) <> "-" Then
    For J = 1 To L
        If Mid(Rng, J, 1) <> "-" Then
            Tem = Mid(Rng, I, 1) & Mid(Rng, J, 1)
            If Not Dic.exists(Tem) Then
                K = K + 1
                Dic.Add Tem, ""
                Arr(1, K) = Tem
            End If
        End If
    Next J
    End If
Next I
Selection.Offset(, 1).Resize(, L ^ 2).ClearContents
Selection.Offset(, 1).Resize(, K).Value = Arr
Set Dic = Nothing
End Sub

 

[Good-Luck]

Vâng, vậy ta có thể ghép số dạng như trong file này em gửi được không vậy?
Ta tách thành 3 CELL để ghép.
Ta lấy giá trị của từng chuỗi số ghép với nhau của CELL D2:F2
Ví dụ: Giá trị ta cho vào
D2 E2 F2
227 816 805
Lọc chuỗi số cho H2 đến BD2
22 27 28 21 26 20 25 Tiếp đến(Vì số 2 có rồi nên bỏ qua) ta lại ghép 77 78 71 76 (Vì 78 có rồi nên ta bỏ qua) 70 75 lại tới 88 82 87 81 86 80 85 cứ như thế tới BD2
Như vạy có được không đại ca.

thay cac bac thay viet code kinh qua, ko biet bai minh don gian vay co dat yeu cau ko

 

[ndu96081631]

Thôi thì hứng lên làm thử bằng công thức cái coi
1> Đặt name

tmp =IF(COUNTIF($D$2,"*"&ROW($1:$10)-1&"*"),ROW($1:$10)-1,"")

UniqueNum =SMALL(tmp,ROW(INDIRECT("1:"&COUNT(tmp))))

2> Công thức liệt kê

=IF(INT((COLUMNS($A:A)-1)/COUNT(tmp))+1>COUNT(tmp),"",INDEX(UniqueNum,INT((COLUMNS($A:A)-1)/COUNT(tmp))+1)&INDEX(UniqueNum,MOD((COLUMNS($A:A)-1),COUNT(tmp))+1))

Kéo fill sang phải
Đề xuất dữ liệu đầu vào nhập vào 1 cell chứ không nên cho riêng 3 cell (ví dụ thế này 227-816-805)
---------------
Nói thêm: Với thuật toán tôi vừa nêu ở trên, nếu triển khai bằng VBA code thì thậm chỉ không cần Dictionary và RegExp vẫn chơi được tuốt ---> Các bạn làm thử xem

 

[dhn46]

Em thử làm cách này thì không cần tới các Object.

Sub Tohop()
Dim i, j As Integer, Arr, Kq As String, Chuoi As String, TmpChuoi as String

TmpChuoi = [D3] & [E3] & [F3]
For i = 1 To Len(TmpChuoi)
    If IsNumeric(Mid(TmpChuoi, i, 1)) Then Chuoi = Chuoi & Mid(TmpChuoi, i, 1)
Next
For i = 1 To Len(Chuoi)
    For j = 1 To Len(Chuoi)
        If i <> j And InStr(1, Kq, Mid(Chuoi, i, 1) & Mid(Chuoi, j, 1)) = 0 Then
            Kq = Kq & Mid(Chuoi, i, 1) & Mid(Chuoi, j, 1) & ","        
       End If    
   Next
Next

Arr = Split(Kq, ",")
Range("h3", Range("h3").End(xlToRight)).ClearContents
[H3].Resize(, UBound(Arr)) = Arr

End Sub

 

[tunhantam]

Cảm ơn các bác nhiều ạ..
Chắc tại em không biết hỏi nên thế.. Dù sao cũng thật cảm ơn mọi người đã nhiệt tình..

 

[ndu96081631]

Cảm ơn các bác nhiều ạ..
Chắc tại em không biết hỏi nên thế.. Dù sao cũng thật cảm ơn mọi người đã nhiệt tình..

Vậy kết luận cuối cùng là sao đây? Vẫn chưa đúng ý của bạn à?

 

[Quang_Hải]

Vậy kết luận cuối cùng là sao đây? Vẫn chưa đúng ý của bạn à?

Vậy đó, tốn bao nhiêu công sức cuối cùng không ai hiểu đúng hay không. Sao em dị ứng với cụm từ "Dù sao cũng cám ơn".

 

[Good-Luck]

Vậy đó, tốn bao nhiêu công sức cuối cùng không ai hiểu đúng hay không. Sao em dị ứng với cụm từ "Dù sao cũng cám ơn".

ít ra người này còn biết quay lại :

Cảm ơn các bác nhiều ạ..

còn nhiêu đứa sau khi làm xong lặng lệ quay đi biệt tâm không một lời từ giã

 

[tunhantam]

Dạ đúng rồi bác ạ.. Cảm ơn mọi người đã giúp đỡ ạ

 

[tunhantam]

Chọn ô C2 hoặc C3 (hoặc ô nào muốn tách) rồi bấm nút. Cái vụ tô màu chưa tính.

Public Sub GPE()
Dim Rng As Range, Arr(), I As Long, J As Long, L As Long, K As Long, Dic As Object, Tem As Variant
Set Dic = CreateObject("Scripting.Dictionary")
Set Rng = Selection
ReDim Arr(1 To 1, 1 To Len(Rng) ^ 2)
L = Len(Rng)
For I = 1 To L
    If Mid(Rng, I, 1) <> "-" Then
    For J = 1 To L
        If Mid(Rng, J, 1) <> "-" Then
            Tem = Mid(Rng, I, 1) & Mid(Rng, J, 1)
            If Not Dic.exists(Tem) Then
                K = K + 1
                Dic.Add Tem, ""
                Arr(1, K) = Tem
            End If
        End If
    Next J
    End If
Next I
Selection.Offset(, 1).Resize(, L ^ 2).ClearContents
Selection.Offset(, 1).Resize(, K).Value = Arr
Set Dic = Nothing
End Sub

Như Code của bác có thể cho Marco chạy nhiều Cell 1 lúc không vậy? Ví dụ mình có nhiều dữ liệu trong C:C và muốn chạy 1 lượt..