Nhờ anh chị diễn đàn sửa giúp mình VBA để sheet"DMKH" có những mã trùng thì bên sheet"TH_Congno" cộng lại ở số dư đầu kỳ giúp mình. ví dụ mã A001 trùng nhau thì bên sheet"TH_CN" số dư đầu kỳ là 520.000.000. Cảm ơn các A/C nhiều
Nhờ sửa VBA để tổng những mã trùng nhau (1 người xem)
- Thread starter thuanntk
- Ngày gửi
Người dùng đang xem chủ đề này
giangleloi
Thành viên gắn bó
- Tham gia
- 25/3/13
- Bài viết
- 1,883
- Được thích
- 1,441
Xài Sumif không được à bạn. Xài code thì lèo tèo có mấy dòng, hông biết có ai buồn ngồi viết chơi không?
Upvote
0
giangleloi
Thành viên gắn bó
- Tham gia
- 25/3/13
- Bài viết
- 1,883
- Được thích
- 1,441
Đâu có nói code vài dòng, đang nói dữ liệu cơ mà chàng ơi. Code có sẵn trong file có chỗ nào gọi là "khủng" nhỉ?Sumif thì quá đơn giản rồi bạn ơi. Ý là họ muốn sửa code trong file kìa. Bạn đã xem code trong í chưa mà bảo lèo tèo có mấy dòng thể...Code khủng long luôn ấy...
Vậy bạn ngồi buồn buồn mà sửa giúp cho người ta đê...
Bạn hỏi sao thì làm vậy nhé (Bị bài trên khích quá nên làm đại cho có bài để nộp)
Mã:
Sub TH()
Dim Arr(), vlArr(1 To 65000, 1 To 5), I, K, Tem
Arr = Sheet8.[B9:G11].Value
Set Dic = CreateObject("Scripting.dictionary")
For I = 1 To UBound(Arr)
Tem = Arr(I, 1)
If Not Dic.exists(Tem) Then
K = K + 1
Dic.Add Tem, K
vlArr(K, 1) = K
vlArr(K, 2) = Arr(I, 1)
vlArr(K, 3) = Arr(I, 2)
vlArr(K, 4) = Arr(I, 5)
vlArr(K, 5) = Arr(I, 6)
Else
vlArr(Dic.Item(Tem), 5) = vlArr(Dic.Item(Tem), 5) + Arr(I, 6)
End If
Next I
Sheet6.[A9].Resize(K, 5) = vlArr
Set Dic = Nothing
End Sub
Upvote
0
comet_1701
Thành viên tiêu biểu
- Tham gia
- 24/5/14
- Bài viết
- 632
- Được thích
- 459
Tham khảo thêm bạn nhé, chỉ lấy đúng yêu cầu số dư:
PHP:
Sub Cong()
Dim Sarr, Darr, I As Long, K As Long, j As Long, Tarr, Tem
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("TH_Congno")
Tarr = .Range(.[B9], .[B65000].End(xlUp)).Value2
End With
For I = 1 To UBound(Tarr)
Tem = Tarr(I, 1)
If Not Dic.exists(Tem) Then
Dic.Add Tem, I
End If
Next I
With Sheets("DMKH")
Sarr = .Range(.[B9], .[B65000].End(xlUp)).Resize(, 6).Value2
End With
ReDim Darr(1 To UBound(Sarr), 1 To 1)
For I = 1 To UBound(Sarr)
Tem = Sarr(I, 1)
If Dic.exists(Tem) Then
Darr(Dic.Item(Tem), 1) = Darr(Dic.Item(Tem), 1) + Sarr(I, 6)
End If
Next I
With Sheets("TH_Congno")
.[E9:E10].ClearContents
.[E9].Resize(I - 1).Value = Darr
End With
Set Dic = Nothing
End Sub
Upvote
0
comet_1701
Thành viên tiêu biểu
- Tham gia
- 24/5/14
- Bài viết
- 632
- Được thích
- 459
Nếu mà làm trong khoảng ngày tháng thì 520 không đúng đâu. Đúng là không đọc kỹ nhưng do bạn nêu ngay từ đầu cũng không rõ ràng. Nếu mà làm trong khoảng thì tồn đầu kỳ sẽ thay đổi theo khoảng đó chứ, đâu mặc định 520tr đươc.
nếu Ps(h,1)<ngay dau thì darr(dic.item(tem),2)= darr(dic.item(tem),2)+phát sinh tăng - phát sinh giảm chứ nhỉ (ví dụ)
Upvote
0
giangleloi
Thành viên gắn bó
- Tham gia
- 25/3/13
- Bài viết
- 1,883
- Được thích
- 1,441
Nói chung là hông có biết sửa code trong file đâu. Code đó chắc chỉ may ra có hpkhuong mới cứu chữa nổi thôi. Bạn dẫn 2 tụi mình đi đúng yêu cầu với.Hình như 2 bạn trên đi lệch yêu cầu của chủ thớt ý... Sửa chứ hok phải viết mới... (Sửa code có sẵn trong file ấy...
P/s: Chủ topic đâu rồi, lên tiếng nhờ anh ý đi. Nhanh kẻo lỡ.
Upvote
0
Tôi hiểu yêu cầu của chủ thớt. Nhưng hok có biết sửa code trong file (nhìn dài quá...hoảng luôn...không biết đâu mà lần.) Chắc chờ tác giả viết nên code đó thôi...(là ai thì có trời mới biết...)
Nhưng/: Nói 1 điều rằng. Bạn chủ topic này yêu cầu hơi "Dỡ Hơi" tí là: Tại sao trong danh mục Khách hàng, 1 khách hàng mà lại đi lặp lại 2 mã , sinh ra 2 số dư đầu kỳ. Đã là danh mục thì chỉ Duy nhất chứ... Ôi thôi...bó chiếu...
Ah, thế này bạn, do 1 khách hàng nhưng ở nhiều chi nhánh khác nhau, giờ mình tính tổng luôn lại cho một mã ở Sheet"TH_congno" đó bạn, bạn giúp mình nhé, cảm ơn bạn nhiều.
Upvote
0
giangleloi
Thành viên gắn bó
- Tham gia
- 25/3/13
- Bài viết
- 1,883
- Được thích
- 1,441
Nếu bạn cho 1 file có vài chục dòng dữ liệu thì sẽ có người giúp bạn, còn với file có 3 dòng dữ liệu thì không biết có ai giúp hay không?
Upvote
0
Mình gửi lại file bạn nhé, mình thấy nhiều dòng cũng bị như vậy bạn ah.
Upvote
0
doveandrose
hello
- Tham gia
- 3/7/09
- Bài viết
- 2,372
- Được thích
- 2,263
Tôi hiểu yêu cầu của chủ thớt. Nhưng hok có biết sửa code trong file (nhìn dài quá...hoảng luôn...không biết đâu mà lần.) Chắc chờ tác giả viết nên code đó thôi...(là ai thì có trời mới biết...)
Nhưng/: Nói 1 điều rằng. Bạn chủ topic này yêu cầu hơi "Dỡ Hơi" tí là: Tại sao trong danh mục Khách hàng, 1 khách hàng mà lại đi lặp lại 2 mã , sinh ra 2 số dư đầu kỳ. Đã là danh mục thì chỉ Duy nhất chứ... Ôi thôi...bó chiếu...
những câu hỏi hấp dẫn như này cứ để chuyên gia xàm trả lời :
tác giả đang ngồi gốc cây đa , muốn tìm thì lên cung trăng mà hỏi
đố biết là nick nào , hí hí
Upvote
0
Ơn giời, cao thủ đây rồi, Bạn giúp mình với nhé
Upvote
0
doveandrose
hello
- Tham gia
- 3/7/09
- Bài viết
- 2,372
- Được thích
- 2,263
bạn nói câu đó là đụng chạm tới các bạn ở trên đấy , các bạn ấy giỏi hơn tôi nhiều , tôi không phải cao thủ , cũng không phải tác giả đoạn code trong file , chỉ có điều tôi biết ai viết đoạn code đó thôi mà
Upvote
0
Let'GâuGâu
Thành viên mới
- Tham gia
- 12/9/13
- Bài viết
- 3,131
- Được thích
- 2,732
tôi ko phải kế toán, nên ko rành lắm
nguồn của bạn là sheet "phátinh" hay sheet "DMKH"?
nếu là sheet DMKH thì lấy ngày ở đâu?
vì sheet "tong-CN" thấy có mục từ ngày...đến ngày?
Upvote
0
comet_1701
Thành viên tiêu biểu
- Tham gia
- 24/5/14
- Bài viết
- 632
- Được thích
- 459
Mình chưa xem file mới của bạn đâu, nếu số dư đầu kỳ dùng sumif hoặc pivot cộng dồn trước rồi chạy thử mặc dù chả hiểu gì, chỉ làm thử theo file cũ, may thì được
PHP:
Sub Cong()
Dim Sarr, Darr, i As Long, k As Long, j As Long, Tem, Tungay, Denngay, Rws As Long
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
FDate = [G5]
EDate = [I5]
With Sheets("DMKH")
Sarr = .Range(.[B9], .[B65000].End(xlUp)).Resize(, 7).Value2
End With
ReDim Darr(1 To UBound(Sarr, 1), 1 To 12)
For i = 1 To UBound(Sarr, 1)
Tem = Sarr(i, 1)
If Not Dic.exists(Tem) Then
k = k + 1
Dic.Add Tem, k
Darr(k, 1) = k
Darr(k, 2) = Sarr(i, 1)
Darr(k, 3) = Sarr(i, 2)
Darr(k, 4) = Sarr(i, 5)
Darr(k, 5) = Sarr(i, 6)
End If
Next i
With Sheets("PHATSINH")
Sarr = .Range(.[D3], .[D65000].End(3)).Resize(, 14).Value2
End With
For i = 1 To UBound(Sarr, 1)
Tem = Sarr(i, 14)
If Sarr(i, 14) <> "" Then
If Dic.exists(Tem) Then
Rws = Dic.Item(Tem)
If Sarr(i, 1) < FDate Then
Darr(Rws, 5) = Darr(Rws, 5) + Sarr(i, 11)
ElseIf Sarr(i, 1) <= EDate Then
Darr(Rws, 7) = Darr(Rws, 7) + Sarr(i, 11)
End If
End If
Darr(Rws, 9) = Darr(Rws, 5) + Darr(Rws, 7)
End If
Next i
With Sheets("TH_Congno")
If k Then
.[A9:J10].ClearContents
.[A9].Resize(k, 10).Value = Darr
End If
End With
Set Dic = Nothing
End SubChắc chạy luôn quá
Lần chỉnh sửa cuối:
Upvote
0
chucuoi92
Thành viên lười biếng
- Tham gia
- 11/9/09
- Bài viết
- 850
- Được thích
- 488
- Giới tính
- Nam
- Nghề nghiệp
- Chăn trâu
code trong file cũ của tác giả là do mình viết, Mình đã xem lại thì thấy tác giả có thảy đổi một sô thứ tự cột trong code. Không biết vì lý do gì mà tác giả lại đưa bài hỏi lại.Thực sự thì tôi biết tác giả...Nhưng không tiện nói ra thôi....nói ra hok có hay lắm...đó mà!!! (nhưng người mà bạn nói chính là i...
Code mình viết trước đây còn nhiều chỗ thừa một phần cũng do chưa nắm vững yêu cầu ngay từ đầu, code chỉ là ghép nối theo yêu cầu và thêm năng lực có hạn. Nếu ai làm được thì giúp, làm mới hoặc sửa(không phải ngại gì cả). GPE là nơi chúng ta học tập, giao lưu mà.
Upvote
0
comet_1701
Thành viên tiêu biểu
- Tham gia
- 24/5/14
- Bài viết
- 632
- Được thích
- 459
Mã:
Sub Cong()
Dim Dic As Object, sArr(), dArr(), I As Long, J As Long, K As Long, fDate As Date, eDate As Date
Dim Tong(1 To 1, 1 To 7), tArr(), N As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DMKH")
tArr = .Range(.[B9], .[B65000].End(xlUp)).Resize(, 7).Value2
End With
ReDim dArr(1 To UBound(tArr, 1), 1 To 10)
With Sheets("PHATSINH")
sArr = .Range(.[D3], .[D65000].End(xlUp)).Resize(, 14).Value2
End With
fDate = [G5]
eDate = [I5]
For I = 1 To UBound(sArr, 1)
If sArr(I, 14) <> "" And sArr(I, 1) <= eDate Then
Tem = sArr(I, 14)
If Not Dic.Exists(Tem) Then
K = K + 1
Dic.Add Tem, K
dArr(K, 1) = K
For N = 1 To UBound(tArr, 1)
If tArr(N, 1) = Tem Then
dArr(K, 2) = tArr(N, 1)
dArr(K, 3) = tArr(N, 2)
dArr(K, 4) = tArr(N, 5)
dArr(K, 5) = tArr(N, 6)
dArr(K, 6) = tArr(N, 7)
Exit For
End If
Next N
If sArr(I, 1) < fDate Then
If sArr(I, 7) = "131" Then
dArr(K, 5) = dArr(K, 5) + sArr(I, 11)
Else
dArr(K, 6) = dArr(K, 6) - sArr(I, 11)
End If
Else
If sArr(I, 7) = "131" Then
dArr(K, 7) = dArr(K, 7) + sArr(I, 11)
Else
dArr(K, 8) = dArr(K, 8) + sArr(I, 11)
End If
End If
Else
If sArr(I, 1) < fDate Then
If sArr(I, 7) = "131" Then
dArr(Dic.Item(Tem), 5) = dArr(Dic.Item(Tem), 5) + sArr(I, 11)
Else
dArr(Dic.Item(Tem), 6) = dArr(Dic.Item(Tem), 6) - sArr(I, 11)
End If
Else
If sArr(I, 7) = "131" Then
dArr(Dic.Item(Tem), 7) = dArr(Dic.Item(Tem), 7) + sArr(I, 11)
Else
dArr(Dic.Item(Tem), 8) = dArr(Dic.Item(Tem), 8) + sArr(I, 11)
End If
End If
End If
End If
Next I
For I = 1 To K
dArr(I, 9) = dArr(I, 5) - dArr(I, 7)
dArr(I, 10) = dArr(I, 6) - dArr(I, 8)
For J = 5 To 10 Step 2
Tong(1, J - 4) = Tong(1, J - 4) + dArr(I, J)
Next J
Next I
With Sheets("TH_Congno")
.[A9:L10].ClearContents
.[A9].Resize(K, 10).Value = dArr
.[E13:J13].Value = Tong
End With
Set Dic = Nothing
End Subở sheet phát sinh, mã đối tượng nên để một cột thôi còn dễ làm (để hai cột mệt lắm). Nếu được số tiền cũng để thêm 1 cột nữa, có thể dễ làm hơn. Để phân biệt thì qua 131 bên nợ, bên có (phát sinh trong file).
Số dư đầu kỳ cộng dồn trước đi bằng pivot cho dễ làm, đợi bác Ba Tê và thành viên khác giúp thêm nhé
số dư cuối kỳ chắc để tránh âm, dùng hàm max hoặc if record macro có khi hết chăng?
Lần chỉnh sửa cuối:
Upvote
0
Bạn ơi, trong code cũ đó nếu mà Sheet "DMKH" mà có mã trùng nhau thì nó không tính tổng lại được. ý mình là khi mã ở Sheet "DMKH" trùng nhau thì cộng lại rồi tính tiếp theo điều kiện theo ngày ở sheet"TH_Congno" để tính được số đầu kỳ. Nói chung là code bạn viết đúng rồi nhưng nếu mà mã ở sheet"DMKH" mà trùng thì cộng lại với nhau là được rồi. bạn giúp lại mình nhé
Upvote
0
comet_1701
Thành viên tiêu biểu
- Tham gia
- 24/5/14
- Bài viết
- 632
- Được thích
- 459
Bài này chủ yếu vướng ở vấn đề bạn nói ở trên thì tạm thời làm thế này đi, đợi người phù hợp qua giúp.
Tạo thêm một sub phụ nữa, chạy sub này trước, rồi chạy sub TH_CN
PHP:
Sub Cong_don()
Dim Sarr, darr, i As Long, k As Long, j As Long, Tem, RWS
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DMKH")
Sarr = .Range(.[B9], .[B65000].End(xlUp)).Resize(, 7).Value2
End With
ReDim darr(1 To UBound(Sarr), 1 To 7)
For i = 1 To UBound(Sarr)
Tem = Sarr(i, 1)
If Not Dic.exists(Tem) Then
k = k + 1
Dic.Add Tem, k
For j = 1 To 7
darr(k, j) = Sarr(i, j)
Next j
Else
RWS = Dic.Item(Tem)
darr(RWS, 6) = darr(RWS, 6) + Sarr(i, 6)
darr(RWS, 7) = darr(RWS, 7) + Sarr(i, 7)
End If
Next i
With Sheets("DMKH")
'.[B18:G27].ClearContents
.[I9].Resize(k, 7).Value = darr
End With
Set Dic = Nothing
End Sub
PHP:
Sub TH_CN()
Dim d As Object
Dim PS, KH, TH, tamPS, tamKH, tamT
Dim h, M, i, j, k As Long
Dim MDT1 As String, MDT2 As String, ma As String
Dim Ndau As Date, Ncuoi As Date
Set d = CreateObject("Scripting.Dictionary")
Ndau = Sheet6.Range("G5").Value
Ncuoi = Sheet6.Range("I5").Value
ma = Sheet6.Range("G4").Value
PS = Sheet1.Range("D3:R" & Sheet1.Range("D65000").End(xlUp).Row)
KH = Sheet8.Range("I9:O" & Sheet8.Range("I65000").End(xlUp).Row)
ReDim tamT(1 To UBound(KH) + UBound(PS), 1 To 10)
ReDim tamPS(1 To UBound(KH) + UBound(PS), 1 To 4)
ReDim tamKH(1 To UBound(KH) + UBound(PS), 1 To 2)
ReDim tamTH(1 To UBound(KH) + UBound(PS), 1 To 3)
On Error Resume Next
For h = 1 To UBound(KH)
If KH(h, 6) <> 0 Or KH(h, 7) <> 0 Then
If KH(h, 5) Like ma Then
If Not d.exists(KH(h, 1)) Then
M = M + 1
d.Add KH(h, 1), M
tamTH(M, 1) = KH(h, 1)
tamTH(M, 2) = KH(h, 2)
tamTH(M, 3) = KH(h, 5)
End If
End If
End If
Next
With Application.WorksheetFunction
For h = 1 To UBound(PS)
MDT1 = PS(h, 14)
MDT2 = PS(h, 15)
If PS(h, 1) <= Ncuoi Then
'If PS(h, 1) >= Ndau And PS(h, 1) <= Ncuoi Then
If PS(h, 7) Like ma And MDT1 <> "" Then
If Not d.exists(MDT1) Then
M = M + 1
d.Add MDT1, M
tamTH(M, 1) = MDT1
tamTH(M, 2) = .VLookup(MDT1, KH, 2, 0)
tamTH(M, 3) = ma
End If
End If
If PS(h, 8) Like ma And MDT2 <> "" Then
If Not d.exists(MDT2) Then
M = M + 1
d.Add MDT2, M
tamTH(M, 1) = MDT2
tamTH(M, 2) = .VLookup(MDT2, KH, 2, 0)
tamTH(M, 3) = ma
End If
End If
End If
Next
For i = 1 To M
For j = 1 To UBound(KH)
If KH(j, 1) Like tamTH(i, 1) And KH(j, 5) Like ma Then
tamKH(i, 1) = KH(j, 6)
tamKH(i, 2) = KH(j, 7)
End If
Next
For k = 1 To UBound(PS)
If PS(k, 1) < Ndau Then
If PS(k, 14) Like tamTH(i, 1) And PS(k, 7) Like ma Then: tamPS(i, 1) = tamPS(i, 1) + PS(k, 11)
If PS(k, 15) Like tamTH(i, 1) And PS(k, 8) Like ma Then: tamPS(i, 2) = tamPS(i, 2) + PS(k, 11)
End If
If PS(k, 1) >= Ndau And PS(k, 1) <= Ncuoi Then
If PS(k, 14) Like tamTH(i, 1) And PS(k, 7) = ma Then: tamPS(i, 3) = tamPS(i, 3) + PS(k, 11)
If PS(k, 15) Like tamTH(i, 1) And PS(k, 8) = ma Then: tamPS(i, 4) = tamPS(i, 4) + PS(k, 11)
End If
Next
tamT(i, 1) = i
tamT(i, 2) = tamTH(i, 1)
tamT(i, 3) = tamTH(i, 2)
tamT(i, 4) = tamTH(i, 3)
tamT(i, 5) = .Max(0, tamKH(i, 1) + tamPS(i, 1) - tamKH(i, 2) - tamPS(i, 2))
tamT(i, 6) = .Max(0, tamKH(i, 2) + tamPS(i, 2) - tamKH(i, 1) - tamPS(i, 1))
tamT(i, 7) = tamPS(i, 3)
tamT(i, 8) = tamPS(i, 4)
tamT(i, 9) = .Max(0, tamT(i, 5) + tamT(i, 7) - tamT(i, 6) - tamT(i, 8))
tamT(i, 10) = Abs(.Min(tamT(i, 5) + tamT(i, 7) - tamT(i, 6) - tamT(i, 8), 0))
Next
tamT(M + 1, 3) = Sheet6.Range("M3").Value
For ii = 5 To 10
tamT(M + 1, ii) = "=SUM(R9C:R[-1]C)"
Next
End With
Application.ScreenUpdating = False
Sheet6.Range("A9").Resize(10000, 10).Clear
Sheet6.Range("A9").Resize(M + 1, 10) = tamT
Sheet6.Range("A9").Offset(M).Resize(, 10).Value = Sheet6.Range("A9").Offset(M).Resize(, 10).Value
Sheet6.Range("A8:J8").Copy
Sheet6.Range("A9").Resize(M + 1, 10).PasteSpecial (xlPasteFormats)
Sheet6.Range("A9").Resize(M, 10).Borders(xlInsideHorizontal).LineStyle = xlContinuous
Sheet6.Range("A9").Resize(M, 10).Borders(xlInsideHorizontal).Weight = xlHairline
Sheet6.Range("A9").Offset(M).Resize(, 10).Select
Selection.Font.Bold = True
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.349986266670736
.PatternTintAndShade = 0
End With
Sheet6.Range("M1:M2").Copy
Sheet6.Range("C" & M + 12 & ":C" & M + 13).PasteSpecial xlPasteAll
Sheet6.Range("N1:N3").Copy
Sheet6.Range("H" & M + 11 & ":H" & M + 12).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheet6.Range("B9").Resize(M, 1).HorizontalAlignment = xlLeft
Sheet6.Range("C9").Resize(M, 1).HorizontalAlignment = xlLeft
Sheet6.Range("A9").Resize(M + 2, 10).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
End Sub
Upvote
0
