VBA quá mạnh mẽ. Em cảm ơn anh nhiều ạ !
Sub ABC()
Dim sArr(), NgaySX(), MH(), Res(), Dic As Object, iKey$, j&
Dim i&, sRow, k&, iR&, jC&, sR&, sC&
Application.ScreenUpdating = False
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
ReDim NgaySX(1 To 1, 1 To 10000)
ReDim MH(1 To 10000, 1 To 2)
With Sheets("Data")
sArr = .Range("Table1").Value
End With
sRow = UBound(sArr)
For i = 1 To sRow
iKey = sArr(i, 5)
If Dic.exists(iKey) = False Then
sC = sC + 1
Dic.Item(iKey) = sC
NgaySX(1, sC) = iKey
End If
iKey = sArr(i, 2)
If Dic.exists(iKey) = False Then
sR = sR + 1
Dic.Item(iKey) = sR
MH(sR, 1) = sArr(i, 2)
End If
Next i
ReDim Res(1 To sR, 1 To sC + 1)
With Sheets("KQ")
.Range("A4").CurrentRegion.ClearContents
.Range("A4").Value = "Ma Hang"
.Range("B4").Value = "Tong"
.Range("A5").Resize(sR, 1) = MH
MH = .Range("A5").Resize(sR, 2).Value
.Range("C4").Resize(1, sC) = NgaySX
NgaySX = .Range("C4").Resize(1, sC).Value
For i = 1 To sR
Dic.Item(MH(i, 1)) = i
Next i
For j = 1 To sC
Dic.Item(NgaySX(1, j)) = j
Next j
For i = 1 To sRow
iKey = sArr(i, 2)
iR = Dic.Item(iKey)
jC = Dic.Item(sArr(i, 5))
Res(iR, jC) = Res(iR, jC) + sArr(i, 7)
MH(iR, 2) = MH(iR, 2) + sArr(i, 7)
Next i
.Range("C5").Resize(sR, sC) = Res
.Range("A5").Resize(sR, 2) = MH
End With
Application.ScreenUpdating = True
End Sub
Pivot table là tiện lợi nhất còn gì?
trên máy em không có bị gì cả ạ. cũng chưa hiểu tại sao bị lỗi đó
Tôi biết tại sao lỗi rồi. Khi ngày đưa vào mảng lại bị đảo ngày thành tháng. Tôi phải sửa lại là NgaySX(1, sC) = Format(iKey, "mm/dd/yyyy") thì code chạy được (Máy tôi định dạng hệ thống trong Control Panel là dd/MM/yyyy)
Nó ra 2 dòng màu vàng kia là do key đưa vào em có để theo mã hàng&ngày. nên khi trả kết quả nó sẽ tác ra làm n lần nếu như cùng mã hàng mà sản xuất ở nhiều ngày
Em cần anh chỉ giáo thêm giúp em.Cái cột tổng.Em chưa biết làm thế nào để cộng dồn. Anh làm thế nào để cái cột tổng nó cộng dồn lại thế ạ. Xin cho em xem code với ạ
Tôi dùng 2 dic: 1 cho mã và 1 cho ngày. Code bài #2 đã sửa theo bài #6:
Sub Pivot_VBA2()
Dim arrS, arrD, arrR
Dim i&, j&, k&
Dim Dic As Object, dic2 As Object
Dim sKey$
arrS = Sheet1.Range("A2:G" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row)
ReDim arrR(1 To UBound(arrS), 1 To 100)
ReDim arrD(1 To 100)
Set Dic = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arrS)
sKey = arrS(i, 2)
If Not Dic.exists(sKey) Then
j = j + 1
Dic.Add sKey, j
arrR(j, 1) = arrS(i, 2)
If Not dic2.exists(arrS(i, 5)) Then
k = k + 1
dic2.Add arrS(i, 5), k
End If
arrR(j, dic2.Item(arrS(i, 5)) + 2) = arrS(i, 7)
arrR(j, 2) = arrS(i, 7)
arrD(k) = arrS(i, 5)
Else
arrR(Dic.Item(sKey), dic2.Item(arrS(i, 5)) + 2) = arrR(Dic.Item(sKey), dic2.Item(arrS(i, 5)) + 2) + arrS(i, 7)
arrR(Dic.Item(sKey), 2) = arrR(Dic.Item(sKey), 2) + arrS(i, 7)
End If
Next
With Sheet3
.Range("C4").Resize(1, 100).ClearContents
.Range("A5").Resize(1000, 100).ClearContents
.Range("A5").Resize(j, k + 2) = arrR
.Range("C4").Resize(1, k) = arrD
.Range("C4:K" & k + 4).Sort Key1:=.Range("C4"), Orientation:=xlLeftToRight
End With
Set Dic = Nothing: Set dic2 = Nothing
End SubCám ơn anh,đã cập nhật lại tại #4
Chạy code
Sub XYZ()
Dim sArr(), aNgay(), aTieuDe(), Res(), Dic As Object, ma$, ngay
Dim i&, sRow, k&, t&, iR&, jC&, sR&, sC&
aTieuDe = Range("A4:B4").Value
With Sheets("Data")
sArr = .Range("B2:G" & .Range("B" & Rows.Count).End(xlUp).Row).Value
End With
sRow = UBound(sArr)
ReDim Res(1 To sRow, -1 To 100)
ReDim aNgay(1 To 100)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To sRow
ngay = sArr(i, 4)
If Not Dic.exists(ngay) Then
t = t + 1
Dic.Add ngay, t
aNgay(t) = ngay
End If
ma = sArr(i, 1)
If Not Dic.exists(ma) Then
k = k + 1
Dic.Add ma, k
Res(k, -1) = ma
End If
iR = Dic.Item(ma): jC = Dic.Item(ngay)
Res(iR, 0) = Res(iR, 0) + sArr(i, 6)
Res(iR, jC) = Res(iR, jC) + sArr(i, 6)
Next i
With Sheets("KQ")
.Range("A4").CurrentRegion.ClearContents
.Range("A4:B4") = aTieuDe
.Range("A5").Resize(k, t + 2) = Res
.Range("C4").Resize(, t) = aNgay
.Range("C4").Resize(k + 1, t).Sort Key1:=.Range("C4"), Orientation:=2
.Range("A5").Resize(k, t + 2).Sort Key1:=.Range("A5"), Orientation:=1
End With
End Sub
Sub TransformData()
Dim cnn As Object, Rst As Object
Dim strQuery As String, fCount As Byte, X As Long
Set cnn = CreateObject("ADODB.Connection")
Set Rst = CreateObject("ADODB.Recordset")
With cnn
.connectionstring = "Provider=Microsoft.ACE.OLEDB.12.0" & _
";Data Source=" & ThisWorkbook.FullName & _
";Extended Properties='Excel 12.0 Xml;HDR=No';"
.Open
End With
strQuery = _
"TRANSFORM " & _
"SUM([t.F7]) " & _
"SELECT " & _
"[t.F2] AS [Ma] " & _
"FROM " & _
"[Data$] AS t " & _
"WHERE " & _
"[t.F3] <> 'Lot' " & _
"GROUP BY " & _
"[t.F2] " & _
"PIVOT " & _
"[t.F5]"
With Rst
.ActiveConnection = cnn
.Source = strQuery
.Open
End With
Sheet2.Range("A20").CurrentRegion.Clear
X = Sheet2.Range("A20").CopyFromRecordset(Rst)
For fCount = 1 To Rst.Fields.Count
Sheet2.Range("A20").Offset(-1, fCount - 1) = Rst.Fields(fCount - 1).Name
Next fCount
With Sheet2
.Range("A20").Offset(X) = "Tong cong"
.Range("A20").Offset(-1, fCount - 1) = "Tong cong"
.Range("A20").Offset(X, 1).Resize(, fCount - 1).FormulaR1C1 = "=SUM(R[-" & X & "]C:R[-1]C)"
.Range("A20").Offset(, fCount - 1).Resize(X).FormulaR1C1 = "=SUM(RC[-" & (fCount - 2) & "]:RC[-1])"
End With
Rst.Close
cnn.Close
Set cnn = Nothing: Set Rst = Nothing
MsgBox "Done", vbInformation, "GPE"
End SubViệc tối ưu hóa vòng lặp của anh quá tuyệt vời
Riêng việc dùng duy nhất 1 dic e thấy rất tuyệt vời ạ.
Thực chất 1 Dic duy nhất đó đang chứa 2 loại dữ liệu mã và ngày. Nếu viết tường minh thì 2 Dic: 1 cho mã và 1 cho ngày. Đây là cách làm tắt mới xuất hiện gần đây.
Có thể khai báo mảng kết quả kiểu -1 thế này được ạ thầy?
Được, khai báo ReDim Res(1 To sRow, -1 To 100) với Ubound >= Lbound và trong giới hạn cho phép của mảng
