Dùng thêm mảng Arr1, code đúng chuẩn mực và minh bạch
Nếu n là 1 số cố định như n=3 chẳng hạn thì code vẫn như vậy, chỉ cần tăng cột của Arr2, tăng số phần tử của Array lên
Sub tt()
Dim numCust As Integer, numCol As Integer, iRow As Integer, iCol As Integer
Dim itemName As String, custTemplate As String
Dim aIn As Variant, custArray As Variant
Dim dic As Object
numCust = Sheets("sheet1").Range("a2").CurrentRegion.Rows.Count - 1
aIn = Sheets("sheet1").Range("a2").CurrentRegion.Offset(1).Resize(numCust)
custTemplate = String(numCust, "0")
Set dic = CreateObject("scripting.dictionary")
For iCol = 2 To UBound(aIn, 2)
For iRow = 1 To numCust
itemName = Trim(CStr(aIn(iRow, iCol)))
If itemName <> "" Then
' nhet vao dic
' If Not dic.exists(itemName) Then dic.Add itemName, custTemplate
custArray = dic(itemName)
If IsEmpty(custArray) Then custArray = custTemplate
Mid(custArray, iRow, 1) = "1" ' ghi khach hang mua mon nay
dic(itemName) = custArray
End If
Next iRow
Next iCol
' bat dau lap mang dau ra
Dim aOut() As Variant, oRow As Integer
ReDim aOut(0 To dic.Count, 0 To numCust)
oRow = 0
For iRow = 1 To numCust ' ghi ten khach hang (hang doc bay gio thannh ngang)
aOut(oRow, iRow) = Trim(CStr(aIn(iRow, 1)))
Next iRow
For iRow = 0 To dic.Count - 1
custArray = dic.items()(iRow)
If Len(Replace(custArray, "0", "")) >= 2 Then ' toi thieu 2 khach hang
oRow = oRow + 1
aOut(oRow, 0) = dic.keys()(iRow)
For iCol = 1 To numCust
If Mid(custArray, iCol, 1) = "1" Then aOut(oRow, iCol) = "X"
Next iCol
End If
Next iRow
Sheets("sheet2").Range("a10").Resize(oRow, numCust + 1) = aOut
Set dic = Nothing
End SubNếu n nhỏ như n=3 hoặc 4 thì gán trực tiếp không cần dùng for, dể hiểu và code cũng không dài hơn (for phải mất 3 dòng lệnh), nếu n lớn thì dùng for của cột với dòng đã xác định theo Item
Sub ttt()
' dung arraylist cho de sort
Const DELIM = "|" ' ky hieu ngan cac phan chuoi
Dim numCust As Integer, iRow As Integer, iCol As Integer
Dim itemName As String
Dim aIn As Variant
Dim aList As Object
numCust = Sheets("sheet1").Range("a2").CurrentRegion.Rows.Count - 1
aIn = Sheets("sheet1").Range("a2").CurrentRegion.Offset(1).Resize(numCust)
Set aList = CreateObject("system.collections.arraylist")
For iCol = 2 To UBound(aIn, 2)
For iRow = 1 To numCust
itemName = Trim(CStr(aIn(iRow, iCol)))
If itemName <> "" Then
' nhet vao
aList.Add itemName & DELIM & CStr(iRow)
End If
Next iRow
Next iCol
aList.Add String(20, Chr(255)) & DELIM & "1" ' dat them 1 phan tu cuoi de duyet cho de hon
aList.Sort
' bat dau lap mang dau ra
Dim aOut() As Variant, oRow As Integer, itemArray As Variant, custCount As Integer
ReDim aOut(0 To aList.Count, 0 To numCust)
oRow = 0
For iRow = 1 To numCust ' ghi ten khach hang (hang doc bay gio thannh ngang)
aOut(oRow, iRow) = Trim(CStr(aIn(iRow, 1)))
Next iRow
itemName = ""
oRow = 1
For iRow = 0 To aList.Count - 1
itemArray = Split(aList.Item(iRow), DELIM)
If itemArray(0) <> itemName Then
' If itemName <> "" Then
' neu hoi du dieu kien in ra thi chuan bi dong moi
' neu khong du dieu kien thi dong moi se chong len dong cu
If custCount >= 2 Then oRow = oRow + 1
For iCol = 1 To numCust ' chuan bi dong moi
aOut(oRow, iCol) = ""
Next iCol
itemName = itemArray(0)
custCount = 0
aOut(oRow, 0) = itemName
End If
aOut(oRow, CInt(itemArray(1))) = "X"
custCount = custCount + 1
Next iRow
Sheets("sheet2").Range("a16").Resize(oRow, numCust + 1) = aOut
Set aList = Nothing
End SubBạn chạy thử code
Sub GPE()
Dim Darr(), Arr(), Key As String, RowsIn As Long, ColsIn As Long, ColsOut As Long
Dim i As Long, j As Long, k As Long, ik As Long, n As Long
With Sheets("sheet1")
RowsIn = .Range("A60000").End(xlUp).Row - 2
ColsIn = .Range("A3").CurrentRegion.Columns.Count
Darr = .Range("A3").Resize(RowsIn, ColsIn).Value
End With
ColsOut = RowsIn + 3
ReDim Arr(1 To 10000, 1 To ColsOut)
With CreateObject("scripting.dictionary")
For i = 1 To RowsIn
For j = 2 To ColsIn
Key = Darr(i, j)
If Key = Empty Then GoTo Tiep 'Du lieu theo cot khong duoc co Cell trong xen giua
If Not .exists(Key) Then
k = k + 1
.Add Key, k
Arr(k, 1) = Key: Arr(k, 2) = 1: Arr(k, ColsOut) = Darr(i, 1)
Else
ik = .Item(Key)
n = Arr(ik, 2) + 1
Arr(ik, 2) = n
If n = 2 Then Arr(ik, 3) = Arr(ik, ColsOut)
Arr(ik, n + 2) = Darr(i, 1)
End If
Tiep:
Next j
Next i
End With
Sheets("sheet2").Range("A3").Resize(k, ColsOut - 1) = Arr
End Sub
