Function tạo tổ hợp N phần tử từ mảng dữ liệu nhiều dòng nhiều cột (1 người xem)

  • Thread starter Thread starter HieuCD
  • Ngày gửi Ngày gửi
Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
H

HieuCD

Chuyên gia GPE
Tham gia
14/9/10
Bài viết
9,887
Được thích
23,618
Nhiều bạn có nhu cầu tạo tổ hợp, mình tạo Function CreateToHop( mảng du lieu ), các bạn góp ý thêm cho hoàn chỉnh :)
Mã: 
Function CreateToHop(ByVal sArr As Variant) As Variant
'CreateToHop: Liet ke to hop N phan tu cua mang "sArr"
'sArr: Là Array hoac Range, neu khac se tra ve "Empty"
  Dim aRow(), Res(), sCol&, sRow&, N&, i&, j&, iR&

  If TypeName(sArr) = "Variant()" Then
    sRow = UBound(sArr, 1):   sCol = UBound(sArr, 2)
  ElseIf TypeName(sArr) = "Range" Then
    sRow = sArr.Rows.Count:   sCol = sArr.Columns.Count
  Else
    Exit Function
  End If
  ReDim aRow(1 To sCol + 1)
  aRow(sCol + 1) = 1
  For j = sCol To 1 Step -1
    aRow(j) = sRow * aRow(j + 1)
  Next j
  N = aRow(1)
  ReDim Res(1 To N, 1 To sCol)
  For i = 1 To N
    For j = 1 To sCol
      iR = ((i - 1) Mod aRow(j)) \ aRow(j + 1) + 1 'Thu tu dong du lieu
      Res(i, j) = sArr(iR, j)
    Next j
  Next i
  CreateToHop = Res
End Function
Sub ví dụ
Mã: 
Sub Main()
  Dim Res As Variant
  Range("G2:K1000000").ClearContents
  Res = CreateToHop(Range("A2:C4").Value)
  Res = CreateToHop(Range("A2:C4"))
  If Res <> Empty Then Range("G2").Resize(UBound(Res, 1), UBound(Res, 2)) = Res
End Sub
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
HieuCD đã viết:
ElseIf TypeName(sArr) = "Range" Then
sRow = sArr.Rows.Count: sCol = sArr.Columns.Count
Else
Nhấp chuột vào đây để mở rộng...
Ở trên có sẵn mảng sArr thì có thể chép luôn Range vào sArr cho đẹp anh. :)
PHP: 
ElseIf TypeName(sArr) = "Range" Then 
If sArr.Count=1 Then Exit Function
sArr = sArr.Value
sRow = UBound(sArr, 1):   sCol = UBound(sArr, 2)
Else
Trong Sub Main() em chạy bị lỗi, chỉnh lại dòng cuối một xíu.

PHP: 
If TypeName(Res) <> "Empty" Then
 
Upvote 0
befaint đã viết:
Ở trên có sẵn mảng sArr thì có thể chép luôn Range vào sArr cho đẹp anh. :)
PHP: 
ElseIf TypeName(sArr) = "Range" Then
If sArr.Count=1 Then Exit Function
sArr = sArr.Value
sRow = UBound(sArr, 1):   sCol = UBound(sArr, 2)
Else
Trong Sub Main() em chạy bị lỗi, chỉnh lại dòng cuối một xíu.

PHP: 
If TypeName(Res) <> "Empty" Then
Nhấp chuột vào đây để mở rộng...
Theo gợi ý của bạn @befaint , và thêm phần bẩy lổi mảng 1 chiều
Chúc các bạn 1 ngày vui :)
Mã: 
Function CreateToHop(ByVal sArr As Variant) As Variant
'CreateToHop: Liet ke to hop N phan tu cua "Mang" 2 chieu "sArr"
'sArr: Là Array hoac Range, neu khac se tra ve "Empty"
  Dim aRow(), Res(), sCol&, sRow&, N As Double, i As Double, j&, iR&, tmp
 
  On Error Resume Next
  If TypeName(sArr) = "Range" Then
    If sArr.Count = 1 Then
      tmp = sArr.Value
      ReDim sArr(1 To 1, 1 To 1)
      sArr(1, 1) = tmp
    Else
      sArr = sArr.Value
    End If
  End If
  sRow = UBound(sArr, 1):   sCol = UBound(sArr, 2)
  If Err.Number > 0 Then Exit Function
 
  ReDim aRow(1 To sCol + 1)
  aRow(sCol + 1) = 1
  For j = sCol To 1 Step -1
    aRow(j) = sRow * aRow(j + 1)
  Next j
  N = aRow(1)
  ReDim Res(1 To N, 1 To sCol)
  For i = 1 To N
    For j = 1 To sCol
      iR = ((i - 1) Mod aRow(j)) \ aRow(j + 1) + 1 'Thu tu dong du lieu
      Res(i, j) = sArr(iR, j)
    Next j
  Next i
  CreateToHop = Res
End Function

Mã: 
Sub Main()
  Dim Res As Variant
  Range("E2:G1000000").ClearContents
  Res = CreateToHop(Range("A2:C4").Value)
  Res = CreateToHop(Range("A2:C4"))
  If TypeName(Res) <> "Empty" Then Range("E2").Resize(UBound(Res, 1), UBound(Res, 2)) = Res
End Sub
File đính kèm có thêm phần nhập công thức trên bảng tính
 

File đính kèm

Upvote 0
HieuCD đã viết:
Theo gợi ý của bạn @befaint , và thêm phần bẩy lổi mảng 1 chiều
Chúc các bạn 1 ngày vui :)
Mã: 
Function CreateToHop(ByVal sArr As Variant) As Variant
'CreateToHop: Liet ke to hop N phan tu cua "Mang" 2 chieu "sArr"
'sArr: Là Array hoac Range, neu khac se tra ve "Empty"
  Dim aRow(), Res(), sCol&, sRow&, N As Double, i As Double, j&, iR&, tmp

  On Error Resume Next
  If TypeName(sArr) = "Range" Then
    If sArr.Count = 1 Then
      tmp = sArr.Value
      ReDim sArr(1 To 1, 1 To 1)
      sArr(1, 1) = tmp
    Else
      sArr = sArr.Value
    End If
  End If
  sRow = UBound(sArr, 1):   sCol = UBound(sArr, 2)
  If Err.Number > 0 Then Exit Function

  ReDim aRow(1 To sCol + 1)
  aRow(sCol + 1) = 1
  For j = sCol To 1 Step -1
    aRow(j) = sRow * aRow(j + 1)
  Next j
  N = aRow(1)
  ReDim Res(1 To N, 1 To sCol)
  For i = 1 To N
    For j = 1 To sCol
      iR = ((i - 1) Mod aRow(j)) \ aRow(j + 1) + 1 'Thu tu dong du lieu
      Res(i, j) = sArr(iR, j)
    Next j
  Next i
  CreateToHop = Res
End Function

Mã: 
Sub Main()
  Dim Res As Variant
  Range("E2:G1000000").ClearContents
  Res = CreateToHop(Range("A2:C4").Value)
  Res = CreateToHop(Range("A2:C4"))
  If TypeName(Res) <> "Empty" Then Range("E2").Resize(UBound(Res, 1), UBound(Res, 2)) = Res
End Sub
File đính kèm có thêm phần nhập công thức trên bảng tính
Nhấp chuột vào đây để mở rộng...
Còn trường hợp 1 chiều nữa anh
Mã: 
If sArr.Columns.Count = 1 or sArr.Rows.Count Then
 
Upvote 0
HieuCD đã viết:
Theo gợi ý của bạn @befaint , và thêm phần bẩy lổi mảng 1 chiều
Chúc các bạn 1 ngày vui :)
Mã: 
Function CreateToHop(ByVal sArr As Variant) As Variant
'CreateToHop: Liet ke to hop N phan tu cua "Mang" 2 chieu "sArr"
'sArr: Là Array hoac Range, neu khac se tra ve "Empty"
  Dim aRow(), Res(), sCol&, sRow&, N As Double, i As Double, j&, iR&, tmp

  On Error Resume Next
  If TypeName(sArr) = "Range" Then
    If sArr.Count = 1 Then
      tmp = sArr.Value
      ReDim sArr(1 To 1, 1 To 1)
      sArr(1, 1) = tmp
    Else
      sArr = sArr.Value
    End If
  End If
  sRow = UBound(sArr, 1):   sCol = UBound(sArr, 2)
  If Err.Number > 0 Then Exit Function

  ReDim aRow(1 To sCol + 1)
  aRow(sCol + 1) = 1
  For j = sCol To 1 Step -1
    aRow(j) = sRow * aRow(j + 1)
  Next j
  N = aRow(1)
  ReDim Res(1 To N, 1 To sCol)
  For i = 1 To N
    For j = 1 To sCol
      iR = ((i - 1) Mod aRow(j)) \ aRow(j + 1) + 1 'Thu tu dong du lieu
      Res(i, j) = sArr(iR, j)
    Next j
  Next i
  CreateToHop = Res
End Function

Mã: 
Sub Main()
  Dim Res As Variant
  Range("E2:G1000000").ClearContents
  Res = CreateToHop(Range("A2:C4").Value)
  Res = CreateToHop(Range("A2:C4"))
  If TypeName(Res) <> "Empty" Then Range("E2").Resize(UBound(Res, 1), UBound(Res, 2)) = Res
End Sub
File đính kèm có thêm phần nhập công thức trên bảng tính
Nhấp chuột vào đây để mở rộng...
Mạnh xem thấy thuật toán rất hay đó ... tuy nhiên chưa hình dung ra ứng dụng nó vào việc gì là hay nhất
Mở rộng thêm chút nữa đi cho code đó nó đi vào thực tế
Cảm ơn nhiều
 
Upvote 0
thuyyeu99 đã viết:
Còn trường hợp 1 chiều nữa anh
Mã: 
If sArr.Columns.Count = 1 or sArr.Rows.Count Then
Nhấp chuột vào đây để mở rộng...
"Range" luôn là "mảng" 2 chiều, nếu là "Range" mình xét hết kể cả chỉ có 1 "ô".
kieu manh đã viết:
Mạnh xem thấy thuật toán rất hay đó ... tuy nhiên chưa hình dung ra ứng dụng nó vào việc gì là hay nhất
Mở rộng thêm chút nữa đi cho code đó nó đi vào thực tế
Cảm ơn nhiều
Nhấp chuột vào đây để mở rộng...
Mình tạo Function từ ý tưởng bài #1334 https://www.giaiphapexcel.com/diendan/threads/các-câu-hỏi-về-mảng-trong-vba-array.46834/page-67
Áp dụng khi phải dùng thuật toán "Vét cạn"
Function thêm tùy chọn loại bỏ ô rổng (Empty) trong vùng dữ liệu, số dòng mỗi cột có thể khác nhau
Luu ý: Khi loại ô rổng, mỗi cột phải có ít nhất 1 giá trị khác rổng, nếu không Function trả về giá trị "Empty"
Mã: 
Function CreateToHop(ByVal sArr As Variant, Optional ByVal bNotBlank = False) As Variant
'CreateToHop: Liet ke to hop N phan tu cua "Mang" 2 chieu "sArr"
'sArr: Là Array hoac Range, neu khac se tra ve "Empty"
'bNotBlank: Là giá tri luan ly, mac dinh = False lay ca gia tri "Empty"
'bNotBlank = True: Loai bo gia tri "Empty", neu có Cot chi co gia tri "Empty", Function tra ve "Empty"
  Dim aRow(), Res(), sCol&, sRow&, N As Double, i As Double, j&, iR&, tmp

  On Error Resume Next
  If TypeName(sArr) = "Range" Then
    If sArr.Count = 1 Then
      tmp = sArr.Value
      ReDim sArr(1 To 1, 1 To 1)
      sArr(1, 1) = tmp
    Else
      sArr = sArr.Value
    End If
  End If
  sRow = UBound(sArr, 1):   sCol = UBound(sArr, 2)
  If Err.Number > 0 Then Exit Function

  Call AddValue_aRow(sArr, aRow, sRow, sCol, bNotBlank)
  N = aRow(1)
  If N = 0 Then Exit Function
  ReDim Res(1 To N, 1 To sCol)
  For i = 1 To N
    For j = 1 To sCol
      iR = ((i - 1) Mod aRow(j)) \ aRow(j + 1) + 1 'Thu tu dong du lieu
      If sArr(iR, j) = Empty Then Res(i, j) = "" Else Res(i, j) = sArr(iR, j)
    Next j
  Next i
  CreateToHop = Res
End Function

Private Sub AddValue_aRow(sArr, aRow, sRow, sCol, bNotBlank)
  Dim i&, j&, k&, tmp
  ReDim aRow(1 To sCol + 1)
  aRow(sCol + 1) = 1
  If bNotBlank = False Then
    For j = sCol To 1 Step -1
      aRow(j) = sRow * aRow(j + 1)
    Next j
  Else
    For j = sCol To 1 Step -1
      k = 0
      For i = 1 To sRow
        tmp = sArr(i, j)
        If Len(tmp) Then
          sArr(i, j) = Empty
          k = k + 1
          sArr(k, j) = tmp
        End If
      Next i
      If k > 0 Then aRow(j) = k * aRow(j + 1)
    Next j
  End If
End Sub
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
HieuCD đã viết:
Function ghép các giá trị từng cột với giá trị của các cột khác, nếu chỉ có 1 cột sẽ trả về kết quả của cột đó
Theo bạn, trường hợp CreateToHop(A1:A3) kết quả nên như thế nào hợp lý hơn?
Nhấp chuột vào đây để mở rộng...
Em nghĩ cái hoán đổi, sắp xếp gép Item vậy là hợp lý rồi hihih
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

micam111
  • Question Question
Cách chạy nhiều đồng hồ đếm giờ trong VBA (2 người xem)
Trả lời
2
Đọc
598
tranduc36
T
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện. (1 người xem)
Trả lời
13
Đọc
104
Hoàng Tuấn 868
H
1
Hỏi về đánh dấu hàng ngang hàng dọc bằng màu khi kích chuột vào 1 ô (1 người xem)
Trả lời
7
Đọc
175
Gà Công Nghệ
Gà Công Nghệ
PhanTuHuong
Sách Lập trình VBA trong AutoCAD đã có mặt
    • Thích
    • Yêu thích
2
Trả lời
20
Đọc
1K
Mr.hieudoanxd
Mr.hieudoanxd
P
Excell code vba : Tìm Cell để sửa dữ liệu
    • Buồn
2
Trả lời
26
Đọc
523
Phạm Trường 80
P
L
Lỗi font khi convert từ pdf
Trả lời
1
Đọc
56
Hoàng Tuấn 868
H
D
Nhờ anh em giúp đỡ.
    • Buồn
Trả lời
2
Đọc
77
SA_DQ
SA_DQ
00029591
Cần hỗ trợ công thức tổng hợp dữ liệu không cần cột phụ Vlookup
Trả lời
2
Đọc
76
DeTong
D
H
Đổi số thành chữ trong office 365 (1 người xem)
Trả lời
19
Đọc
1K
HoangTan891026
H
Gà Công Nghệ
Lấy dữ liệu file excel từ sheet này sang sheet khác (1 người xem)
Trả lời
4
Đọc
129
Gà Công Nghệ
Gà Công Nghệ
N
Mong mọi người giúp đỡ
Trả lời
1
Đọc
59
minhminh27
minhminh27
minhduc1o2
Excel lỗi font Time New Roman+
Trả lời
7
Đọc
116
minhduc1o2
minhduc1o2
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
0
Đọc
75
fujishima
F
H
Lọc dữ liệu trong XL
    • Cười
Trả lời
0
Đọc
46
huong.dinh
H
giaiphap
Add-Ins hổ trợ Word trộn danh sách và lưu ra nhiều tệp tin khác nhau. (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
2
Trả lời
39
Đọc
9K
fujishima
F
K
xin file excel bảng đấu bóng đá (1 người xem)
    • Yêu thích
2 3
Trả lời
40
Đọc
25K
subin1905
S
B
Xin giải pháp chống sửa, xóa dữ liệu đã nhập vào từ ngày hôm trước.
    • Thích
2
Trả lời
24
Đọc
7K
chihuumvc
C
Trungvt3
Công thức trả về định dạng không như mong muốn và viết phân số trong 1 ô.
Trả lời
1
Đọc
66
bebo021999
B
G
Hướng dẫn Lập danh sách File
    • Không thích
Trả lời
16
Đọc
269
thanhhuy_hvnh
thanhhuy_hvnh
baolong240793
Nhờ Anh/Chị hỗ trợ em hàm Randbetween() với ạ.
Trả lời
4
Đọc
362
bebo021999
B
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALK SHOW: CÙNG NHẢY LAM BA ĐA VỚI HÀM LAMBDA (λ) EXCEL 365
Back
Top Bottom