AnhThu-1976
Thành viên tích cực
- Tham gia
- 17/10/14
- Bài viết
- 1,019
- Được thích
- 163
Bạn thử dùng Sub này xem sao:Các bạn giúp tôi viết code như sau:
Tôi có Sheet NhapBan, từ sheet này tôi muốn cộng dồn số lượng theo ngày và theo mã hàng hóa (Mã hàng hóa có thể nhiều hơn, đây chỉ là file demo)
Tôi muốn kết quả chạy code như ở sheet KQ
Cảm ơn các bạn!
Sub Tonghop()
Dim Dic As Object, Tem As String
Dim sArr(), dArr(1 To 65535, 1 To 3)
Dim i As Long, j As Long, K As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("NhapBan")
sArr = .Range("G18", .Range("G65535").End(3)).Resize(, 15).Value
For i = 1 To UBound(sArr)
For j = 13 To 15
If sArr(i, j) <> Empty Then
Tem = sArr(i, 1) & "#" & .Cells(17, j + 6)
If Not Dic.Exists(Tem) Then
K = K + 1
Dic.Add Tem, K
dArr(K, 1) = sArr(i, 1)
dArr(K, 2) = .Cells(17, j + 6)
dArr(K, 3) = sArr(i, j)
Else
dArr(Dic.Item(Tem), 3) = dArr(Dic.Item(Tem), 3) + sArr(i, j)
End If
End If
Next j
Next i
End With
With Sheets("KQ")
With .Range("A5:C65535")
.ClearContents
.Borders.LineStyle = xlNone
End With
.Range("A5").Resize(K, 3) = dArr
With .Range("A5").Resize(K, 3)
.Borders.LineStyle = xlContinuous
.Borders(xlInsideHorizontal).Weight = xlHairline
End With
End With
End Sub
Bạn thử dùng Sub này xem sao:
Mã:Sub Tonghop() .... With .Range("A5:[COLOR=#0000ff]C65535[/COLOR]") .ClearContents [COLOR=#0000ff].Borders.LineStyle = xlNone[/COLOR] ... End Sub
Dạ. Vì bạn ấy nói mã hàng còn nhiều nên em đưa xuống dòng 65535 anh ạ.
sArr = .Range("G18", .Range("G65535").End(3)).Resize(, 15).Value
For i = 1 To UBound(sArr)
For j = 13 To 15
C = .Range("IV17").End(xlToLeft).Column - 6
Dạ vâng. Em cũng chưa tính đến cái đó thầy ạNếu nhiều hơn 3 mã hàng thì các con số 15 trong này không chính xác:
Phải cho nó là một biến nào đó khác con số cố định 15, ví dụ:PHP:sArr = .Range("G18", .Range("G65535").End(3)).Resize(, 15).Value For i = 1 To UBound(sArr) For j = 13 To 15
PHP:C = .Range("IV17").End(xlToLeft).Column - 6
còn nhiều mã hàng nên cột cuối sẽ lớn hơn cột U, các khai báoDạ. Vì bạn ấy nói mã hàng còn nhiều nên em đưa xuống dòng 65535 anh ạ.
dArr(1 To 65535, 1 To 3)
sArr = .Range("G18", .Range("G65535").End(3)).Resize(, 15).Value
Dựa vào góp ý của anh và thầy Ba tê.Em thử sưa như thế này có được không anh:còn nhiều mã hàng nên cột cuối sẽ lớn hơn cột U, các khai báosẽ phá sảnMã:dArr(1 To 65535, 1 To 3) sArr = .Range("G18", .Range("G65535").End(3)).Resize(, 15).Value
vừa dùng mảng vừa dùng cells rất phức tạp và làm chậm code
mình nghĩ bạn nên dùng 2 mãng dữ liệu: mảng 1 chứa cột ngày, mãng 2 chứa các cột mã hàng gồm dòng đầu là mã hàng các dòng dưới là số lượng, lúc đó dể viết hơn, dĩ nhiên phải dùng End để xác định cột cuối
Sub Tonghop()
Dim Dic As Object, Tem As String
Dim sArr(), tArr(), dArr(1 To 65535, 1 To 3)
Dim i As Long, j As Long, K As Long, C As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("NhapBan")
C = .Range("IV17").End(xlToLeft).Column - 6
tArr = .Range("S17", .Range("IV17").End(xlToLeft)).Value
sArr = .Range("G18", .Range("G65535").End(3)).Resize(, C).Value
For i = 1 To UBound(sArr)
For j = 1 To UBound(tArr, 2)
If sArr(i, j + 12) <> Empty Then
Tem = sArr(i, 1) & "#" & tArr(1, j)
If Not Dic.Exists(Tem) Then
K = K + 1
Dic.Add Tem, K
dArr(K, 1) = sArr(i, 1)
dArr(K, 2) = tArr(1, j)
dArr(K, 3) = sArr(i, j + 12)
Else
dArr(Dic.Item(Tem), 3) = dArr(Dic.Item(Tem), 3) + sArr(i, j + 12)
End If
End If
Next j
Next i
End With
With Sheets("KQ")
With .Range("A5:C65535")
.ClearContents
.Borders.LineStyle = xlNone
End With
.Range("A5").Resize(K, 3) = dArr
With .Range("A5").Resize(K, 3)
.Borders.LineStyle = xlContinuous
.Borders(xlInsideHorizontal).Weight = xlHairline
End With
End With
End Sub
Sub Tonghop()
Dim Dic As Object, Tem As String
Dim sArr(), tArr(), dArr(1 To 65535, 1 To 3)
Dim i As Long, j As Long, K As Long, C As Long, LastR As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("NhapBan")
[COLOR=#ff0000]LastR[/COLOR] = .Range("G18").End(xlDown).Row 'dòng cuoi
[COLOR=#ff0000]C[/COLOR] = .Range("IV17").End(xlToLeft).Column [COLOR=#ff0000]- 18[/COLOR] 'só cot ma hàng
[COLOR=#ff0000]tArr[/COLOR] = .Range("G17:G" & [COLOR=#ff0000]LastR[/COLOR]).Value 'Array ngày tháng
[COLOR=#ff0000]sArr[/COLOR] = .Range("S17:S" & [COLOR=#ff0000]LastR).Resize(, C)[/COLOR].Value 'Array ma hàng
For i = [COLOR=#FF0000]2[/COLOR] To UBound(tArr)
For j = 1 To [COLOR=#ff0000]UBound(sArr, 2)[/COLOR]
If sArr(i, j) <> Empty Then
Tem = tArr(i, 1) & "#" & sArr([COLOR=#ff0000]1[/COLOR], j)
...
dArr(K, 3) = sArr(i, j)
With Sheets("NhapBan")
C = .Range("IV17").End(xlToLeft).Column - 6
sArr = .Range("[COLOR=#ff0000]G17[/COLOR]", .Range("G65535").End(3)).Resize(, C).Value
For i = [COLOR=#ff0000]2[/COLOR] To UBound(sArr)
For j = [COLOR=#ff0000]13[/COLOR] To UBound(sArr, 2)
If sArr(i, j) <> Empty Then
Tem = sArr(i, 1) & "#" & sArr([COLOR=#ff0000]1[/COLOR], j)
If Not Dic.Exists(Tem) Then
K = K + 1
Dic.Add Tem, K
dArr(K, 1) = sArr(i, 1)
dArr(K, 2) = sArr(1, j)
dArr(K, 3) = sArr(i, j)
Else
dArr(Dic.Item(Tem), 3) = dArr(Dic.Item(Tem), 3) + sArr(i, j)
End If
End If
Next j
Next i
End With
Cám ơn anh nhiều. Thật là hay quáhoặc bạn có thể dùng 1 mảng lưu dữ liệuMã:With Sheets("NhapBan") C = .Range("IV17").End(xlToLeft).Column - 6 sArr = .Range("[COLOR=#ff0000]G17[/COLOR]", .Range("G65535").End(3)).Resize(, C).Value For i = [COLOR=#ff0000]2[/COLOR] To UBound(sArr) For j = [COLOR=#ff0000]13[/COLOR] To UBound(sArr, 2) If sArr(i, j) <> Empty Then Tem = sArr(i, 1) & "#" & sArr([COLOR=#ff0000]1[/COLOR], j) If Not Dic.Exists(Tem) Then K = K + 1 Dic.Add Tem, K dArr(K, 1) = sArr(i, 1) dArr(K, 2) = sArr(1, j) dArr(K, 3) = sArr(i, j) Else dArr(Dic.Item(Tem), 3) = dArr(Dic.Item(Tem), 3) + sArr(i, j) End If End If Next j Next i End With
Các bạn giúp tôi viết code như sau:
Tôi có Sheet NhapBan, từ sheet này tôi muốn cộng dồn số lượng theo ngày và theo mã hàng hóa (Mã hàng hóa có thể nhiều hơn, đây chỉ là file demo)
Tôi muốn kết quả chạy code như ở sheet KQ
Cảm ơn các bạn!
Em biết dùng PivotTable sẽ nhanh, nhưng vì kết quả của em sẽ sử dụng tiếp để lập báo cáo khác, vì nếu sử dụng PivotTable thì fải xử lý nữa ( chẳng hạn fải bỏ bớt 1 số râu ria)Bài này tôi thấy dùng PivotTable là ngon nhất. Dữ liệu càng nhiều thì càng thấy nó lợi hại
Ngày | HĐ | TK | Mã Hàng | Tên hàng | Số Lượng |
01/01/17 | H001 | 25 | |||
01/01/17 | H002 | 15 | |||
01/01/17 | H003 | 60 | |||
01/01/17 | H004 | 100 | |||
02/01/17 | H001 | 10 | |||
03/01/17 | H001 | 5 | |||
03/01/17 | H002 | 40 | |||
05/01/17 | H002 | 40 | |||
05/01/17 | H003 | 50 | |||
06/01/17 | H001 | 10 | |||
06/01/17 | H002 | 20 | |||
06/01/17 | H003 | 20 | |||
10/01/17 | H001 | 20 | |||
10/01/17 | H002 | 40 | |||
10/01/17 | H003 | 50 |
Sub TongHop_1()Dim Dic As Object, Tem As String
Dim C
Dim sArr(), dArr(1 To 65535, 1 To 3)
Dim i As Long, j As Long, K As Long
Set Dic = CreateObject("Scripting.Dictionary")
'**************
With Sheets("NhapBan")
C = .Range("IV17").End(xlToLeft).Column - 6
sArr = .Range("G17", .Range("G65535").End(3)).Resize(, C).Value
For i = 2 To UBound(sArr)
For j = 13 To UBound(sArr, 2)
If sArr(i, j) <> Empty Then
Tem = sArr(i, 1) & "#" & sArr(1, j)
If Not Dic.Exists(Tem) Then
K = K + 1
Dic.Add Tem, K
dArr(K, 1) = sArr(i, 1)
dArr(K, 2) = sArr(1, j)
dArr(K, 3) = sArr(i, j)
Else
dArr(Dic.Item(Tem), 3) = dArr(Dic.Item(Tem), 3) + sArr(i, j)
End If
End If
Next j
Next i
End With
'***********
With Sheets("KQ")
With .Range("A5:C65535")
.ClearContents
.Borders.LineStyle = xlNone
End With
Dic.Add Tem, K
dArr(K, 1) = sArr(i, 1)
[COLOR=#ff0000][B] dArr(K, 2) = ""
dArr(K, 3) = ""[/B][/COLOR]
dArr(K, 4) = sArr(1, j)
[COLOR=#ff0000][B]dArr(K, 5) = ""[/B][/COLOR]
dArr(K, 6) = sArr(i, j)
Bác khai báo lại cái dArr thành dArr(1 To 65535, 1 To 6) .Vì Cái dArr hiện tại có 3 cộtCảm ơn Các Thầy & anh chị đã giúp đỡ
Em có sửa (chỗ màu đỏ), nhưng nó báo lỗi
Vậy Các Thầy & các bạn giúp giùm!Mã:Dic.Add Tem, K dArr(K, 1) = sArr(i, 1) [COLOR=#ff0000][B] dArr(K, 2) = "" dArr(K, 3) = ""[/B][/COLOR] dArr(K, 4) = sArr(1, j) [COLOR=#ff0000][B]dArr(K, 5) = ""[/B][/COLOR] dArr(K, 6) = sArr(i, j)
Em cảm ơn.
Cảm ơn bạn nhiều !!!!!!!!!!!!Bác khai báo lại cái dArr thành dArr(1 To 65535, 1 To 6) .Vì Cái dArr hiện tại có 3 cột
Không hiểu bạn nói bỏ bớt râu ria là gì cảCảm ơn Các Thầy & anh chị đã giúp đỡ
Em biết dùng PivotTable sẽ nhanh, nhưng vì kết quả của em sẽ sử dụng tiếp để lập báo cáo khác, vì nếu sử dụng PivotTable thì fải xử lý nữa ( chẳng hạn fải bỏ bớt 1 số râu ria)
Em có thử làm, nhưng hay bị dính chữ "Total" ở các dòng nên fải xóa nó điKhông hiểu bạn nói bỏ bớt râu ria là gì cả
???
Bạn cần kết quả thế nào, tôi ra kết quả y chang thế thôi, có vấn đề gì chứ?
View attachment 174822
Em có thử làm, nhưng hay bị dính chữ "Total" ở các dòng nên fải xóa nó đi
Mặc khác, theo cách làm của thầy, thì ta fải tiếp tục xử lý copy ngày xuống dưới (Ví dụ Copy ngày 01/01/17 ở mã hàng H001, để paste ở mã hàng H002, H003...
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2