Tạo Macro nhập liệu

lvh1064 · 10/11/21

Các bạn giúp mình với, mình có thao tác lập đi lặp lại dễ sai quá, cụ thể tìm con số kỹ thuật rồi nhập ngày tương ứng nhưng dãy số dài và nhìn dễ nhầm nên mình tạo một sheet mới, ở đây chỉ nhập số kỹ thuật và nhập ngày sau đó nhấn nút macro nó tự động sang sheet hai tìm con số kỹ thuật rồi nhập ngày theo cột tương ứng. Cám ơn các bạn nhiều nhé. Xin vui lòng nhìn file đính kèm theo.

HUONGHCKT · 10/11/21

lvh1064 đã viết:
Các bạn giúp mình với, mình có thao tác lập đi lặp lại dễ sai quá, cụ thể tìm con số kỹ thuật rồi nhập ngày tương ứng nhưng dãy số dài và nhìn dễ nhầm nên mình tạo một sheet mới, ở đây chỉ nhập số kỹ thuật và nhập ngày sau đó nhấn nút macro nó tự động sang sheet hai tìm con số kỹ thuật rồi nhập ngày theo cột tương ứng. Cám ơn các bạn nhiều nhé. Xin vui lòng nhìn file đính kèm theo.

Bạn dùng thử, hy vọng đúng.

Hoàng Tuấn 868 · 10/11/21

..................

Hoàng Tuấn 868 · 11/11/21

lvh1064 đã viết:
Các bạn giúp mình với, mình có thao tác lập đi lặp lại dễ sai quá, cụ thể tìm con số kỹ thuật rồi nhập ngày tương ứng nhưng dãy số dài và nhìn dễ nhầm nên mình tạo một sheet mới, ở đây chỉ nhập số kỹ thuật và nhập ngày sau đó nhấn nút macro nó tự động sang sheet hai tìm con số kỹ thuật rồi nhập ngày theo cột tương ứng. Cám ơn các bạn nhiều nhé. Xin vui lòng nhìn file đính kèm theo.

Bạn tham khảo thêm một cách.

lvh1064 · 11/11/21

HUONGHCKT đã viết:
Bạn dùng thử, hy vọng đúng.

Cám ơn bạn rất nhiều nhưng khi mình chép chương trình thì báo lỗi Run-time error '424' Object required
ở vị trí dòng này Lr = .Cells(Rows.Count, 3).End(x1Up).Row, không biết lỗi ở đâu. Giúp mình với. Cám ơn nhiều.

HUONGHCKT · 11/11/21

lvh1064 đã viết:
Cám ơn bạn rất nhiều nhưng khi mình chép chương trình thì báo lỗi Run-time error '424' Object required
ở vị trí dòng này Lr = .Cells(Rows.Count, 3).End(x1Up).Row, không biết lỗi ở đâu. Giúp mình với. Cám ơn nhiều.

Dòng trước dòng này là With Sheet2.
Nếu không phải Sheet2 thì bạn phải With sheets("ten Sh")
Lr = .Cells(Rows.Count, 3).End(x1Up).Row . Cột tìm dòng cuối cùng là cột 3 , bạn tìm dòng cuối cùng có dữ liệu ở cột nào thì thay số 3 thành chỉ số của cột ấy.

lvh1064 · 11/11/21

Bạn có thể giải thích cho mình hiểu câu lệnh này không Lr = .Cells(Rows.Count, 3).End(x1Up).Row, suy nghĩ không ra được, Cám ơn bạn nhiều nhé.

lvh1064 đã viết:
Cám ơn bạn rất nhiều nhưng khi mình chép chương trình thì báo lỗi Run-time error '424' Object required
ở vị trí dòng này Lr = .Cells(Rows.Count, 3).End(x1Up).Row, không biết lỗi ở đâu. Giúp mình với. Cám ơn nhiều.

Hoàng Tuấn 868 · 11/11/21

lvh1064 đã viết:
Các bạn giúp mình với

Nếu bạn không dùng file của mình thì để mình bỏ đi nhé.

dương hằng 247 · 11/11/21

HUONGHCKT đã viết:
Dòng trước dòng này là With Sheet2.
Nếu không phải Sheet2 thì bạn phải With sheets("ten Sh")
Lr = .Cells(Rows.Count, 3).End(x1Up).Row . Cột tìm dòng cuối cùng là cột 3 , bạn tìm dòng cuối cùng có dữ liệu ở cột nào thì thay số 3 thành chỉ số của cột ấy.

Mình xin lỗi, mình cũng đang bị lỗi khi sử dụng 1 file VBA, nhờ bạn xem giúp, lỗi error 13 đoạn code như sau (khi bấm debug thì nó ra chỗ dòng màu đỏ):
Option Explicit
Public sSoCT As String
Dim curCho&, curNhan&
Dim curSLCho As Double, curSLNhan As Double
Dim curSLChoDu As Double, curSLNhanThieu As Double, SLChia As Double
Dim rngCho As Range, rngNhan As Range, rngData As Range, rngDMTK As Range
Dim endR&, eRow&, eR&, iR&, iRow&, SoDong&
Dim i&, j&, k&, m&, s&, T&, u&, n&
Dim DemNo&, DemCo&, Dem&, dongDau&, iCT&
Dim Wf As WorksheetFunction, Dic As Object
Const ColTkNo = 8: Const ColTkCo = 9: Const RowEnd = 400000
Dim Arr(), ArrNo(), ArrCo(), ArrTK(), arrCho(), arrNhan(), ArrSap(), ArrDM(), ArrSoCT()
Dim Tg
Dim ArrKq(1 To 2000, 1 To 16)
Sub TaoRng()
Set Wf = WorksheetFunction
iRow = 2 'dong dau NKC
With Sheets("NKC")
.Range("A" & iRow & "

" & RowEnd).ClearContents
End With
With Sheets("Tmp")
endR = .Range("A" & RowEnd).End(xlUp).Row
ArrTK = .Range(.Cells(2, 14), .Cells(u, 16)).Value
End With
dongDau = 0
eRow = UBound(ArrTK)
For iCT = 1 To eRow
sSoCT = ArrTK(iCT, 1) 'so CT
Dem = ArrTK(iCT, 2) + ArrTK(iCT, 3) 'so lan N + C
If Dem = 0 Then GoTo exit_for
''*******************************************************'
''Day la phan tinh toan cac TH, co ban la xac dinh cac vung RngCho va RngNhan'
DemNo = ArrTK(iCT, 2) 'so lan N'
DemCo = ArrTK(iCT, 3) 'so lan C'
TaoSubRng
''**************************************************
'Truong hop nay la toan No
If DemCo = 0 Then
TinhToan07
GoTo exit_for
End If
''**************************************************
''Truong hop nay la toan Co
If DemNo = 0 Then
TinhToan08
GoTo exit_for
End If
''**************************************************
''Truong hop khac - TH nay nhieu nhat
'Truong hop nay la soct vua co No vua co Co
Select Case Dem
Case 2
''luc nay DemNo=1 va demCo =1
TinhToan01
Case Is > 2 'so record > 2
''Them 1 TH neu so TK No = So TK Co, STien No(1)=sotienco(1), SotienNo(end)=sotienco(end)
If Dem < 5 And DemNo = DemCo Then
If rngNhan(1, 9) = rngCho(1, 8) And rngNhan(DemCo, 9) = rngCho(DemNo, 8) Then
TinhToan04
GoTo exit_for
End If
End If
If DemNo = 1 Then 'quan he 1N nhieu C
TinhToan02
GoTo exit_for
End If
If DemCo = 1 Then 'quan he 1C nhieu N
TinhToan03
GoTo exit_for
End If
''quan he nhieu no nhieu co
If Wf.CountIf(rngCh

ffset(, 7).Resize(, 1), "<0") = DemNo Then
''Truong hop nay la so tien No toan am
TinhToan06
GoTo exit_for
Else
TinhToan05
GoTo exit_for
End If
End Select
exit_for:
dongDau = dongDau + Dem
If dongDau >= endR Then Exit Sub
Next iCT
Erase ArrTK, arrCho(), arrNhan(), ArrKq
Set rngCho = Nothing: Set rngNhan = Nothing
End Sub
Sub TaoNKC()
With Application
.ScreenUpdating = False: .DisplayAlerts = False: .Calculation = xlCalculationManual: .EnableEvents = False
End With
Tg = Timer
Sheets("NKC").Select
Sheets("NKC").AutoFilterMode = False
'Co the them 1 UDF kiem tra sh Tmp da ton tai
If SheetExists("Tmp") Then
With Sheets("Tmp")
.Cells.ClearContents
.[B1] = "SoCT" 'them tieu de
.[N1] = "SoCT": .[O1] = "DemNo": .[P1] = "DemCo": .[Q1] = "NgayHT"
End With
'Neu chua co thi add
Else
Sheets.Add
ActiveSheet.Name = "Tmp"
End If
ConvertGoc2Tmp
TaoTmp
TaoRng
'*********************************
XuLySoCT
Sheets("Tmp").Delete
MsgBox "Cam on ban da su dung - Dien dan Giai phap Excel" & Chr(13) & Timer - Tg
With Application
.ScreenUpdating = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .EnableEvents = True
End With
End Sub
Sub TaoSubRng()
With Sheets("Tmp")
If DemNo = 0 Then
Set rngNhan = .Cells(2 + dongDau, 2).Offset(DemNo, -1).Resize(DemCo, 13)
GoTo bien
End If
If DemCo = 0 Then
Set rngCho = .Cells(2 + dongDau, 2).Offset(, -1).Resize(DemNo, 12)
GoTo bien
End If
Set rngCho = .Cells(2 + dongDau, 2).Offset(, -1).Resize(DemNo, 12)
Set rngNhan = .Cells(2 + dongDau, 2).Offset(DemNo, -1).Resize(DemCo, 13)
bien:
arrCho = rngCho.Value: arrNhan = rngNhan.Value
End With
End Sub
Sub XuLySoCT()
Dim endR&, i&
Dim Arr(), ArrSoTT()
Dim aSplit() As String
Dim SearchChar$
SearchChar = ";"
With Sheets("NKC")
.AutoFilterMode = False
endR = .Cells(RowEnd, 1).End(3).Row
Arr = .Range("B2:B" & endR).Value
End With
ReDim ArrSoTT(1 To UBound(Arr), 1 To 1)
For i = 1 To UBound(Arr)
aSplit() = Split(Arr(i, 1), SearchChar)
Arr(i, 1) = aSplit(1)
ArrSoTT(i, 1) = i
Next i
With Sheets("NKC")
.Range("B2:B" & endR).Value = Arr
.Range("F2:F" & endR).Value = ArrSoTT
End With
Erase Arr, ArrSoTT
End Sub

Sub GanArr()
With Sheets("NKC")
.Cells(iRow, 1).Resize(SoDong, 9) = ArrKq
End With
iRow = iRow + SoDong
Erase ArrKq
End Sub
Sub TaoTmp()
With Sheets("Tmp")
.AutoFilterMode = False
endR = .Cells(RowEnd, 2).End(xlUp).Row
Arr = .Range("A2:M" & endR + 1).Value 'them +1'
End With
endR = UBound(Arr)
ReDim ArrNo(1 To endR, 1 To 13), ArrCo(1 To endR, 1 To 13), ArrTK(1 To endR, 1 To 7)
s = 0: T = 0: u = 1
For i = 1 To endR - 1
'Gan phan no
If Arr(i, 8) <> 0 Then 'sotien no <>0
s = s + 1
For k = 1 To 4
ArrNo(s, k) = Arr(i, k)
Next k
If Arr(i, 12) <> 0 Then
For k = 10 To 11
ArrNo(s, k) = Arr(i, k)
Next k
ArrNo(s, 12) = Arr(i, 12)
ArrNo(s, 6) = Arr(i, 12) / Arr(i, 8)
End If
ArrNo(s, 5) = "N"
ArrNo(s, 7) = CStr(Arr(i, 7)) ' & Arr(i, 5)) SHTK & CostStr
ArrNo(s, 8) = Arr(i, 8) 'so tien
ArrTK(u, 2) = ArrTK(u, 2) + 1 ' dem so N
ArrTK(u, 5) = ArrTK(u, 5) + Arr(i, 8) 'so tien N
End If
'Gan phan co
If Arr(i, 9) <> 0 Then 'sotien co <>0
T = T + 1
For k = 1 To 4
ArrCo(T, k) = Arr(i, k)
Next k
If Arr(i, 13) <> 0 Then
For k = 10 To 11
ArrCo(T, k) = Arr(i, k)
Next k
ArrCo(T, 13) = Arr(i, 13)
ArrCo(T, 6) = Arr(i, 13) / Arr(i, 9)
End If
ArrCo(T, 5) = "C"
ArrCo(T, 7) = CStr(Arr(i, 7)) '& Arr(i, 5)) 'SHTK & CostStr
ArrCo(T, 9) = Arr(i, 9) 'so tien
ArrTK(u, 3) = ArrTK(u, 3) + 1 ' dem so C
ArrTK(u, 6) = ArrTK(u, 6) + Arr(i, 9) 'so tien C
End If
'tao DM TK duy nhat voi dieu kien la soct da sort******
ArrTK(u, 1) = Arr(i, 2) 'soct
ArrTK(u, 4) = Arr(i, 1) 'NgayHT
ArrTK(u, 7) = ArrTK(u, 6) - ArrTK(u, 5) 'Chenh lech
If ArrTK(u, 1) <> Arr(i + 1, 2) Then u = u + 1
'co nen gan bien dem vao
Next i
With Sheets("tmp")
.[B1] = "SoCT"
.Range("A2:M" & RowEnd).ClearContents
.Range("N2:Q" & RowEnd).ClearContents
.Range("A2").Resize(s, 13) = ArrNo
.Range("A2").Offset(s, 0).Resize(T, 13) = ArrCo
.[N1] = "SoCT": .[O1] = "DemNo": .[P1] = "DemCo": .[Q1] = "NgayHT"
.Range("N2").Resize(u, 7) = ArrTK
End With
Erase Arr(), ArrNo(), ArrCo(), ArrTK
With Sheets("Tmp")
endR = s + T + 1
'sort tmp
Set rngData = .Range(.Cells(1, 1), .Cells(endR, 13))
With .Sort
With .SortFields
.Clear
.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending 'Dieu kien 1 ngayCT
.Add Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending 'Dieu kien 2 soct
.Add Key:=Range("H1"), SortOn:=xlSortOnValues, Order:=xlAscending 'Dieu kien 4 Tien No
.Add Key:=Range("I1"), SortOn:=xlSortOnValues, Order:=xlAscending 'Dieu kien 5 Tien co
End With
.SetRange rngData
.Header = xlYes ' co tieu de hay khong'
.Apply
End With
'sort soct duy nhat
Set rngData = .Range("N2:Q" & u)
With .Sort
With .SortFields
.Clear
.Add Key:=rngData.Cells(1, 4), SortOn:=xlSortOnValues, Order:=xlAscending 'Dieu kien 1 ngayHT
.Add Key:=rngData.Cells(1, 1), SortOn:=xlSortOnValues, Order:=xlAscending 'Dieu kien 2 soct
End With
.SetRange rngData
.Header = xlNo ' co tieu de hay khong'
.Apply
End With
End With
Set rngData = Nothing
End Sub
Sub ConvertGoc2Tmp()
Dim ArrKq()
With Sheets("NKCGoc")
.AutoFilterMode = False
endR = .Cells(RowEnd, 1).End(3).Row
Arr = .Range("A3:I" & endR).Value
End With
ReDim ArrKq(1 To UBound(Arr), 1 To 9)
s = 0
For i = 1 To UBound(Arr)
If Len(Arr(i, 7)) > 0 Then
s = s + 1
ArrKq(s, 1) = Arr(i, 1)
ArrKq(s, 2) = Arr(i, 1) & ";" & Arr(i, 2)
ArrKq(s, 3) = Arr(i, 3)
ArrKq(s, 7) = CStr(Arr(i, 7))
ArrKq(s, 4) = Arr(i, 4)
ArrKq(s, 5) = Arr(i, 5)
ArrKq(s, 6) = Arr(i, 6)
ArrKq(s, 8) = Arr(i, 8) * 1
ArrKq(s, 9) = Arr(i, 9) * 1
End If

Next i
With Sheets("Tmp")
.[A2].Resize(RowEnd, 9).ClearContents
.[A2].Resize(s, 9) = ArrKq
Set rngData = .Range("A2:I" & s + 1)
With .Sort
With .SortFields
.Clear
.Add Key:=rngData.Cells(1, 1), SortOn:=xlSortOnValues, Order:=xlAscending 'Dieu kien 1 ngayHT
.Add Key:=rngData.Cells(1, 2), SortOn:=xlSortOnValues, Order:=xlAscending 'Dieu kien 2 soct
.Add Key:=rngData.Cells(1, 3), SortOn:=xlSortOnValues, Order:=xlAscending 'Dieu kien 2 ngayCT
End With
.SetRange rngData
.Header = xlNo ' co tieu de hay khong'
.Apply
End With
End With
Erase Arr(), ArrKq()
Set rngData = Nothing
End Sub
Sub TaoShTmp()
With Application
.ScreenUpdating = False: .DisplayAlerts = False: .Calculation = xlCalculationManual: .EnableEvents = False
End With
If SheetExists("Tmp") Then
With Sheets("Tmp")
.AutoFilterMode = False
.Cells.ClearContents
.[B1] = "SoCT" 'them tieu de
.[N1] = "SoCT": .[O1] = "DemNo": .[P1] = "DemCo": .[Q1] = "NgayHT"
.[R1] = "PSNo": .[S1] = "PSCo"
End With
'Neu chua co thi add
Else
Sheets.Add
ActiveSheet.Name = "Tmp"
End If
ConvertGoc2Tmp
TaoTmp
With Application
.ScreenUpdating = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .EnableEvents = True
End With
Sheets("Tmp").Select
Range("N1").Select

End Sub
Private Function SheetExists(shName) As Boolean
Dim x As Object
On Error Resume Next
Set x = ActiveWorkbook.Sheets(shName)
If Err = 0 Then SheetExists = True _
Else SheetExists = False
End Function
Sub TinhToan01()
'Truong hop nay danh cho 1N va 1C - Dem=2
SoDong = 1
ArrKq(SoDong, 1) = arrNhan(1, 1) 'ngay HT
ArrKq(SoDong, 2) = sSoCT 'SoCT
ArrKq(SoDong, 3) = arrNhan(1, 3) 'NgayCT
ArrKq(SoDong, 4) = arrNhan(1, 4) 'diengiai
ArrKq(SoDong, ColTkNo) = arrCho(1, 7) 'TKNo
ArrKq(SoDong, ColTkCo) = arrNhan(1, 7) 'TKCo;
ArrKq(SoDong, 7) = arrNhan(1, 9) 'sotien
'********************************
If arrNhan(1, 6) > 0 Then
ArrKq(SoDong, 14) = arrNhan(1, 10) 'MaKH
ArrKq(SoDong, 15) = arrNhan(1, 11) 'TenKH
ArrKq(SoDong, 16) = Round(arrNhan(1, 6) * ArrKq(SoDong, 7), 0) 'ST VND
End If
GanArr
End Sub
Sub TinhToan05()
curCho = 0: curNhan = 0: s = 1
curSLNhanThieu = 0: curSLChoDu = 0: SLChia = 0
'Phan nay la nhieu no nhieu co
Do While Not (curCho = UBound(arrCho) And curSLChoDu = 0)
If curSLChoDu = 0 Then
curCho = curCho + 1
curSLCho = arrCho(curCho, 8)
curSLChoDu = curSLCho
End If
If curSLNhanThieu = 0 Then
curNhan = curNhan + 1
curSLNhan = arrNhan(curNhan, 9)
curSLNhanThieu = curSLNhan
End If
If Abs(curSLChoDu) <= Abs(curSLNhanThieu) Then
SLChia = curSLChoDu
Else
SLChia = curSLNhanThieu
End If
'Xem lai phan nay xu ly tru so am
ArrKq(s, 1) = arrCho(curCho, 1) 'Ngay HT
ArrKq(s, 2) = sSoCT 'SoCT
ArrKq(s, 3) = arrCho(curCho, 3) 'NgayCT
ArrKq(s, 4) = arrCho(curCho, 4) 'Dien giai
ArrKq(s, ColTkNo) = arrCho(curCho, 7) ' TK No
ArrKq(s, ColTkCo) = arrNhan(curNhan, 7) ' TK Co
ArrKq(s, 7) = SLChia 'So tien
' If arrCho(curCho, 6) > 0 Then
' ArrKQ(s, 14) = arrCho(curCho, 10) 'MaKH
' ArrKQ(s, 15) = arrCho(curCho, 11) 'TenKH
' ArrKQ(s, 16) = Round(arrCho(curCho, 6) * ArrKQ(s, 7), 0) 'ST VND
' End If
curSLChoDu = curSLChoDu - SLChia
curSLNhanThieu = curSLNhanThieu - SLChia
s = s + 1
Loop
SoDong = s - 1
GanArr
End Sub
'Phan code duoi day it khi dung
'*********************************************
Sub TinhToan06()
curCho = 0: curNhan = 0: s = 1
curSLNhanThieu = 0: curSLChoDu = 0: SLChia = 0
'With Sheets("NKC")
'***---------------------------------------------------------
'Phan nay la nhieu no nhieu co vµ tat ca la so <0
Do While Not (curCho = UBound(arrCho) And curSLChoDu = 0)
If curSLChoDu = 0 Then
curCho = curCho + 1
curSLCho = arrCho(curCho, 8)
curSLChoDu = curSLCho
End If
If curSLNhanThieu = 0 Then
curNhan = curNhan + 1
curSLNhan = arrNhan(curNhan, 9)
curSLNhanThieu = curSLNhan
End If
If curSLChoDu >= curSLNhanThieu Then 'lay so < lon hon
SLChia = curSLChoDu
Else
SLChia = curSLNhanThieu
End If
ArrKq(s, 1) = arrCho(curCho, 1) 'Ngay HT
ArrKq(s, 2) = sSoCT 'SoCT
ArrKq(s, 3) = arrCho(curCho, 3) 'NgayCT
ArrKq(s, 4) = arrCho(curCho, 4) 'Dien giai
ArrKq(s, ColTkNo) = arrCho(curCho, 7) ' TK No
ArrKq(s, ColTkCo) = arrNhan(curNhan, 7) ' TK Co
ArrKq(s, 7) = SLChia 'So tien
If arrCho(curCho, 6) > 0 Then 'Ti gia
ArrKq(s, 14) = arrCho(curCho, 10) 'MaKH
ArrKq(s, 15) = arrCho(curCho, 11) 'TenKH
ArrKq(s, 16) = Round(ArrKq(s, 7) * arrCho(curCho, 6), 0) 'VND
End If
curSLChoDu = curSLChoDu - SLChia
curSLNhanThieu = curSLNhanThieu - SLChia
s = s + 1
Loop
SoDong = s - 1
GanArr
End Sub

Sub TinhToan02()
'Truong hop nay danh cho 1N va many C - Dem>2
SoDong = UBound(arrNhan)
n = 1 '1 No
For i = 1 To SoDong
For k = 1 To 4
ArrKq(i, k) = arrNhan(i, k) '4 cot dau
Next k
For k = 14 To 16
ArrKq(i, k) = arrNhan(i, k - 4) '3 cot sau
Next k
ArrKq(i, ColTkNo) = arrCho(n, 7) 'TKNo
ArrKq(i, ColTkCo) = arrNhan(i, 7) 'TKCo
ArrKq(i, 7) = arrNhan(i, 9) 'So tien
If arrNhan(i, 6) > 0 Then
ArrKq(i, 14) = arrNhan(i, 10) 'MaKH
ArrKq(i, 15) = arrNhan(i, 11) 'TenKH
ArrKq(i, 16) = Round(arrNhan(i, 6) * ArrKq(i, 7), 0) 'ST VND
End If
Next i
GanArr
End Sub
Sub TinhToan03()
'Truong hop nay danh cho 1C va many N - Dem>2
'TH nay nguoc voi TinhToan02 - be care Tuan
SoDong = UBound(arrCho)
n = 1 '1 No
For i = 1 To SoDong
For k = 1 To 4
ArrKq(i, k) = arrCho(i, k) '4 cot dau
Next k
ArrKq(i, ColTkNo) = arrCho(i, 7) 'TKNo
ArrKq(i, ColTkCo) = arrNhan(n, 7) 'TKCo
ArrKq(i, 7) = arrCho(i, 8) 'So tien
If arrCho(i, 6) > 0 Then
ArrKq(i, 14) = arrCho(i, 10) 'MaKH
ArrKq(i, 15) = arrCho(i, 11) 'TenKH
ArrKq(i, 16) = Round(arrCho(i, 6) * ArrKq(i, 7), 0) 'ST VND
End If
Next i
GanArr
End Sub
Sub TinhToan04()
' TH neu so TK No = So TK Co, STien No(1)=sotienco(1), SotienNo(end)=sotienco(end)
'MsgBox "OK"
SoDong = UBound(arrCho)
For i = 1 To SoDong
For k = 1 To 4
ArrKq(i, k) = arrCho(i, k) '4 cot dau
Next k
ArrKq(i, ColTkNo) = arrCho(i, 7) 'TKNo
ArrKq(i, ColTkCo) = arrNhan(i, 7) 'TKCo
ArrKq(i, 7) = arrCho(i, 8) 'So tien
If arrCho(i, 6) > 0 Then
ArrKq(i, 14) = arrCho(i, 10) 'MaKH
ArrKq(i, 15) = arrCho(i, 11) 'TenKH
ArrKq(i, 16) = Round(arrCho(i, 6) * ArrKq(i, 7), 0) 'ST VND
End If
Next i
GanArr
End Sub
Sub TinhToan07()
' TH neu co nhieu TK No va khong co TK Co
SoDong = UBound(arrCho)
For i = 1 To SoDong
For k = 1 To 4
ArrKq(i, k) = arrCho(i, k) '4 cot dau
Next k
For k = 10 To 3
ArrKq(i, k) = arrCho(i, k) '4 cot sau
Next k
ArrKq(i, ColTkNo) = arrCho(i, 7) 'TKNo
ArrKq(i, ColTkCo) = "" 'TKCo
ArrKq(i, 7) = arrCho(i, 8) 'So tien
If arrCho(i, 6) > 0 Then
ArrKq(i, 14) = arrCho(i, 10) 'MaKH
ArrKq(i, 15) = arrCho(i, 11) 'TenKH
ArrKq(i, 16) = Round(arrCho(i, 6) * ArrKq(i, 7), 0) 'ST VND
End If
Next i
GanArr
End Sub
Sub TinhToan08()
' TH neu co nhieu TK Co va khong co TK No
SoDong = UBound(arrNhan)
n = 1 '1 No
For i = 1 To SoDong
For k = 1 To 4
ArrKq(i, k) = arrNhan(i, k) '4 cot dau
Next k
For k = 10 To 13
ArrKq(i, k) = arrNhan(i, k) '4 cot sau
Next k
ArrKq(i, ColTkNo) = "" 'arrCho(n, 7) 'TKNo
ArrKq(i, ColTkCo) = arrNhan(i, 7) 'TKCo
ArrKq(i, 7) = arrNhan(i, 9) 'So tien
If arrNhan(i, 6) > 0 Then
ArrKq(i, 14) = arrNhan(i, 10) 'MaKH
ArrKq(i, 15) = arrNhan(i, 11) 'TenKH
ArrKq(i, 16) = Round(arrNhan(i, 6) * ArrKq(i, 7), 0) 'ST VND
End If
Next i
GanArr
End Sub
Sub TaoSoCtNew()
Dim endR&, i&, s&, sTmp$, SoDong&
Dim Arr(), ArrKq()
Const RowEnd = 400000
With Sheets("NKC-Tmp")
.AutoFilterMode = False
endR = .Cells(RowEnd, 2).End(3).Row
Arr = .Range("A8:I" & endR).Value
End With
ReDim ArrKq(1 To UBound(Arr), 1 To 9)
s = 1: SoDong = 0
sTmp = "xxxxx"
For i = 1 To UBound(Arr)
If i > 1 Then sTmp = Arr(i - 1, 2)
If CStr(Arr(i, 2)) <> CStr(sTmp) Then SoDong = SoDong + 1
If Len(Arr(i, 7)) > 0 Then
ArrKq(s, 1) = Arr(i, 1)
ArrKq(s, 2) = Right("0000" & SoDong, 5) & ";" & Arr(i, 2)
ArrKq(s, 3) = Arr(i, 3)
ArrKq(s, 7) = CStr(Arr(i, 7))
ArrKq(s, 4) = Arr(i, 4)
ArrKq(s, 5) = Arr(i, 5)
ArrKq(s, 6) = Arr(i, 6)
ArrKq(s, 8) = Arr(i, 8) * 1
ArrKq(s, 9) = Arr(i, 9) * 1
s = s + 1
End If
Next i
If s Then
With Sheets("NKCGoc")
.Range("A3:I" & endR).ClearContents
.[A3].Resize(s, 9) = ArrKq
End With
End If
Erase Arr(), ArrKq()
End Sub
Cảm ơn bạn rất nhiều!!!

Hoàng Tuấn 868 · 11/11/21

dương hằng 247 đã viết:
Mình xin lỗi, mình cũng đang bị lỗi khi sử dụng 1 file VBA, nhờ bạn xem giúp, lỗi error 13 đoạn code như sau (khi bấm debug thì nó ra chỗ dòng màu vàng):
Option Explicit
Public sSoCT As String
Dim curCho&, curNhan&
Dim curSLCho As Double, curSLNhan As Double
Dim curSLChoDu As Double, curSLNhanThieu As Double, SLChia As Double
Dim rngCho As Range, rngNhan As Range, rngData As Range, rngDMTK As Range
Dim endR&, eRow&, eR&, iR&, iRow&, SoDong&
Dim i&, j&, k&, m&, s&, T&, u&, n&
Dim DemNo&, DemCo&, Dem&, dongDau&, iCT&
Dim Wf As WorksheetFunction, Dic As Object
Const ColTkNo = 8: Const ColTkCo = 9: Const RowEnd = 400000
Dim Arr(), ArrNo(), ArrCo(), ArrTK(), arrCho(), arrNhan(), ArrSap(), ArrDM(), ArrSoCT()
Dim Tg
Dim ArrKq(1 To 2000, 1 To 16)
Sub TaoRng()
Set Wf = WorksheetFunction
iRow = 2 'dong dau NKC
With Sheets("NKC")
.Range("A" & iRow & "" & RowEnd).ClearContents
End With
With Sheets("Tmp")
endR = .Range("A" & RowEnd).End(xlUp).Row
ArrTK = .Range(.Cells(2, 14), .Cells(u, 16)).Value
End With
dongDau = 0
eRow = UBound(ArrTK)
For iCT = 1 To eRow
sSoCT = ArrTK(iCT, 1) 'so CT
Dem = ArrTK(iCT, 2) + ArrTK(iCT, 3) 'so lan N + C
If Dem = 0 Then GoTo exit_for
''*******************************************************'
''Day la phan tinh toan cac TH, co ban la xac dinh cac vung RngCho va RngNhan'
DemNo = ArrTK(iCT, 2) 'so lan N'
DemCo = ArrTK(iCT, 3) 'so lan C'
TaoSubRng
''**************************************************
'Truong hop nay la toan No
If DemCo = 0 Then
TinhToan07
GoTo exit_for
End If
''**************************************************
''Truong hop nay la toan Co
If DemNo = 0 Then
TinhToan08
GoTo exit_for
End If
''**************************************************
''Truong hop khac - TH nay nhieu nhat
'Truong hop nay la soct vua co No vua co Co
Select Case Dem
Case 2
''luc nay DemNo=1 va demCo =1
TinhToan01
Case Is > 2 'so record > 2
''Them 1 TH neu so TK No = So TK Co, STien No(1)=sotienco(1), SotienNo(end)=sotienco(end)
If Dem < 5 And DemNo = DemCo Then
If rngNhan(1, 9) = rngCho(1, 8) And rngNhan(DemCo, 9) = rngCho(DemNo, 8) Then
TinhToan04
GoTo exit_for
End If
End If
If DemNo = 1 Then 'quan he 1N nhieu C
TinhToan02
GoTo exit_for
End If
If DemCo = 1 Then 'quan he 1C nhieu N
TinhToan03
GoTo exit_for
End If
''quan he nhieu no nhieu co
If Wf.CountIf(rngChffset(, 7).Resize(, 1), "<0") = DemNo Then
''Truong hop nay la so tien No toan am
TinhToan06
GoTo exit_for
Else
TinhToan05
GoTo exit_for
End If
End Select
exit_for:
dongDau = dongDau + Dem
If dongDau >= endR Then Exit Sub
Next iCT
Erase ArrTK, arrCho(), arrNhan(), ArrKq
Set rngCho = Nothing: Set rngNhan = Nothing
End Sub
Sub TaoNKC()
With Application
.ScreenUpdating = False: .DisplayAlerts = False: .Calculation = xlCalculationManual: .EnableEvents = False
End With
Tg = Timer
Sheets("NKC").Select
Sheets("NKC").AutoFilterMode = False
'Co the them 1 UDF kiem tra sh Tmp da ton tai
If SheetExists("Tmp") Then
With Sheets("Tmp")
.Cells.ClearContents
.[B1] = "SoCT" 'them tieu de
.[N1] = "SoCT": .[O1] = "DemNo": .[P1] = "DemCo": .[Q1] = "NgayHT"
End With
'Neu chua co thi add
Else
Sheets.Add
ActiveSheet.Name = "Tmp"
End If
ConvertGoc2Tmp
TaoTmp
TaoRng
'*********************************
XuLySoCT
Sheets("Tmp").Delete
MsgBox "Cam on ban da su dung - Dien dan Giai phap Excel" & Chr(13) & Timer - Tg
With Application
.ScreenUpdating = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .EnableEvents = True
End With
End Sub
Sub TaoSubRng()
With Sheets("Tmp")
If DemNo = 0 Then
Set rngNhan = .Cells(2 + dongDau, 2).Offset(DemNo, -1).Resize(DemCo, 13)
GoTo bien
End If
If DemCo = 0 Then
Set rngCho = .Cells(2 + dongDau, 2).Offset(, -1).Resize(DemNo, 12)
GoTo bien
End If
Set rngCho = .Cells(2 + dongDau, 2).Offset(, -1).Resize(DemNo, 12)
Set rngNhan = .Cells(2 + dongDau, 2).Offset(DemNo, -1).Resize(DemCo, 13)
bien:
arrCho = rngCho.Value: arrNhan = rngNhan.Value
End With
End Sub
Sub XuLySoCT()
Dim endR&, i&
Dim Arr(), ArrSoTT()
Dim aSplit() As String
Dim SearchChar$
SearchChar = ";"
With Sheets("NKC")
.AutoFilterMode = False
endR = .Cells(RowEnd, 1).End(3).Row
Arr = .Range("B2:B" & endR).Value
End With
ReDim ArrSoTT(1 To UBound(Arr), 1 To 1)
For i = 1 To UBound(Arr)
aSplit() = Split(Arr(i, 1), SearchChar)
Arr(i, 1) = aSplit(1)
ArrSoTT(i, 1) = i
Next i
With Sheets("NKC")
.Range("B2:B" & endR).Value = Arr
.Range("F2:F" & endR).Value = ArrSoTT
End With
Erase Arr, ArrSoTT
End Sub

Sub GanArr()
With Sheets("NKC")
.Cells(iRow, 1).Resize(SoDong, 9) = ArrKq
End With
iRow = iRow + SoDong
Erase ArrKq
End Sub
Sub TaoTmp()
With Sheets("Tmp")
.AutoFilterMode = False
endR = .Cells(RowEnd, 2).End(xlUp).Row
Arr = .Range("A2:M" & endR + 1).Value 'them +1'
End With
endR = UBound(Arr)
ReDim ArrNo(1 To endR, 1 To 13), ArrCo(1 To endR, 1 To 13), ArrTK(1 To endR, 1 To 7)
s = 0: T = 0: u = 1
For i = 1 To endR - 1
'Gan phan no
If Arr(i, 8) <> 0 Then 'sotien no <>0
s = s + 1
For k = 1 To 4
ArrNo(s, k) = Arr(i, k)
Next k
If Arr(i, 12) <> 0 Then
For k = 10 To 11
ArrNo(s, k) = Arr(i, k)
Next k
ArrNo(s, 12) = Arr(i, 12)
ArrNo(s, 6) = Arr(i, 12) / Arr(i, 8)
End If
ArrNo(s, 5) = "N"
ArrNo(s, 7) = CStr(Arr(i, 7)) ' & Arr(i, 5)) SHTK & CostStr
ArrNo(s, 8) = Arr(i, 8) 'so tien
ArrTK(u, 2) = ArrTK(u, 2) + 1 ' dem so N
ArrTK(u, 5) = ArrTK(u, 5) + Arr(i, 8) 'so tien N
End If
'Gan phan co
If Arr(i, 9) <> 0 Then 'sotien co <>0
T = T + 1
For k = 1 To 4
ArrCo(T, k) = Arr(i, k)
Next k
If Arr(i, 13) <> 0 Then
For k = 10 To 11
ArrCo(T, k) = Arr(i, k)
Next k
ArrCo(T, 13) = Arr(i, 13)
ArrCo(T, 6) = Arr(i, 13) / Arr(i, 9)
End If
ArrCo(T, 5) = "C"
ArrCo(T, 7) = CStr(Arr(i, 7)) '& Arr(i, 5)) 'SHTK & CostStr
ArrCo(T, 9) = Arr(i, 9) 'so tien
ArrTK(u, 3) = ArrTK(u, 3) + 1 ' dem so C
ArrTK(u, 6) = ArrTK(u, 6) + Arr(i, 9) 'so tien C
End If
'tao DM TK duy nhat voi dieu kien la soct da sort******
ArrTK(u, 1) = Arr(i, 2) 'soct
ArrTK(u, 4) = Arr(i, 1) 'NgayHT
ArrTK(u, 7) = ArrTK(u, 6) - ArrTK(u, 5) 'Chenh lech
If ArrTK(u, 1) <> Arr(i + 1, 2) Then u = u + 1
'co nen gan bien dem vao
Next i
With Sheets("tmp")
.[B1] = "SoCT"
.Range("A2:M" & RowEnd).ClearContents
.Range("N2:Q" & RowEnd).ClearContents
.Range("A2").Resize(s, 13) = ArrNo
.Range("A2").Offset(s, 0).Resize(T, 13) = ArrCo
.[N1] = "SoCT": .[O1] = "DemNo": .[P1] = "DemCo": .[Q1] = "NgayHT"
.Range("N2").Resize(u, 7) = ArrTK
End With
Erase Arr(), ArrNo(), ArrCo(), ArrTK
With Sheets("Tmp")
endR = s + T + 1
'sort tmp
Set rngData = .Range(.Cells(1, 1), .Cells(endR, 13))
With .Sort
With .SortFields
.Clear
.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending 'Dieu kien 1 ngayCT
.Add Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending 'Dieu kien 2 soct
.Add Key:=Range("H1"), SortOn:=xlSortOnValues, Order:=xlAscending 'Dieu kien 4 Tien No
.Add Key:=Range("I1"), SortOn:=xlSortOnValues, Order:=xlAscending 'Dieu kien 5 Tien co
End With
.SetRange rngData
.Header = xlYes ' co tieu de hay khong'
.Apply
End With
'sort soct duy nhat
Set rngData = .Range("N2:Q" & u)
With .Sort
With .SortFields
.Clear
.Add Key:=rngData.Cells(1, 4), SortOn:=xlSortOnValues, Order:=xlAscending 'Dieu kien 1 ngayHT
.Add Key:=rngData.Cells(1, 1), SortOn:=xlSortOnValues, Order:=xlAscending 'Dieu kien 2 soct
End With
.SetRange rngData
.Header = xlNo ' co tieu de hay khong'
.Apply
End With
End With
Set rngData = Nothing
End Sub
Sub ConvertGoc2Tmp()
Dim ArrKq()
With Sheets("NKCGoc")
.AutoFilterMode = False
endR = .Cells(RowEnd, 1).End(3).Row
Arr = .Range("A3:I" & endR).Value
End With
ReDim ArrKq(1 To UBound(Arr), 1 To 9)
s = 0
For i = 1 To UBound(Arr)
If Len(Arr(i, 7)) > 0 Then
s = s + 1
ArrKq(s, 1) = Arr(i, 1)
ArrKq(s, 2) = Arr(i, 1) & ";" & Arr(i, 2)
ArrKq(s, 3) = Arr(i, 3)
ArrKq(s, 7) = CStr(Arr(i, 7))
ArrKq(s, 4) = Arr(i, 4)
ArrKq(s, 5) = Arr(i, 5)
ArrKq(s, 6) = Arr(i, 6)
ArrKq(s, 8) = Arr(i, 8) * 1
ArrKq(s, 9) = Arr(i, 9) * 1
End If

Next i
With Sheets("Tmp")
.[A2].Resize(RowEnd, 9).ClearContents
.[A2].Resize(s, 9) = ArrKq
Set rngData = .Range("A2:I" & s + 1)
With .Sort
With .SortFields
.Clear
.Add Key:=rngData.Cells(1, 1), SortOn:=xlSortOnValues, Order:=xlAscending 'Dieu kien 1 ngayHT
.Add Key:=rngData.Cells(1, 2), SortOn:=xlSortOnValues, Order:=xlAscending 'Dieu kien 2 soct
.Add Key:=rngData.Cells(1, 3), SortOn:=xlSortOnValues, Order:=xlAscending 'Dieu kien 2 ngayCT
End With
.SetRange rngData
.Header = xlNo ' co tieu de hay khong'
.Apply
End With
End With
Erase Arr(), ArrKq()
Set rngData = Nothing
End Sub
Sub TaoShTmp()
With Application
.ScreenUpdating = False: .DisplayAlerts = False: .Calculation = xlCalculationManual: .EnableEvents = False
End With
If SheetExists("Tmp") Then
With Sheets("Tmp")
.AutoFilterMode = False
.Cells.ClearContents
.[B1] = "SoCT" 'them tieu de
.[N1] = "SoCT": .[O1] = "DemNo": .[P1] = "DemCo": .[Q1] = "NgayHT"
.[R1] = "PSNo": .[S1] = "PSCo"
End With
'Neu chua co thi add
Else
Sheets.Add
ActiveSheet.Name = "Tmp"
End If
ConvertGoc2Tmp
TaoTmp
With Application
.ScreenUpdating = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .EnableEvents = True
End With
Sheets("Tmp").Select
Range("N1").Select

End Sub
Private Function SheetExists(shName) As Boolean
Dim x As Object
On Error Resume Next
Set x = ActiveWorkbook.Sheets(shName)
If Err = 0 Then SheetExists = True _
Else SheetExists = False
End Function
Sub TinhToan01()
'Truong hop nay danh cho 1N va 1C - Dem=2
SoDong = 1
ArrKq(SoDong, 1) = arrNhan(1, 1) 'ngay HT
ArrKq(SoDong, 2) = sSoCT 'SoCT
ArrKq(SoDong, 3) = arrNhan(1, 3) 'NgayCT
ArrKq(SoDong, 4) = arrNhan(1, 4) 'diengiai
ArrKq(SoDong, ColTkNo) = arrCho(1, 7) 'TKNo
ArrKq(SoDong, ColTkCo) = arrNhan(1, 7) 'TKCo;
ArrKq(SoDong, 7) = arrNhan(1, 9) 'sotien
'********************************
If arrNhan(1, 6) > 0 Then
ArrKq(SoDong, 14) = arrNhan(1, 10) 'MaKH
ArrKq(SoDong, 15) = arrNhan(1, 11) 'TenKH
ArrKq(SoDong, 16) = Round(arrNhan(1, 6) * ArrKq(SoDong, 7), 0) 'ST VND
End If
GanArr
End Sub
Sub TinhToan05()
curCho = 0: curNhan = 0: s = 1
curSLNhanThieu = 0: curSLChoDu = 0: SLChia = 0
'Phan nay la nhieu no nhieu co
Do While Not (curCho = UBound(arrCho) And curSLChoDu = 0)
If curSLChoDu = 0 Then
curCho = curCho + 1
curSLCho = arrCho(curCho, 8)
curSLChoDu = curSLCho
End If
If curSLNhanThieu = 0 Then
curNhan = curNhan + 1
curSLNhan = arrNhan(curNhan, 9)
curSLNhanThieu = curSLNhan
End If
If Abs(curSLChoDu) <= Abs(curSLNhanThieu) Then
SLChia = curSLChoDu
Else
SLChia = curSLNhanThieu
End If
'Xem lai phan nay xu ly tru so am
ArrKq(s, 1) = arrCho(curCho, 1) 'Ngay HT
ArrKq(s, 2) = sSoCT 'SoCT
ArrKq(s, 3) = arrCho(curCho, 3) 'NgayCT
ArrKq(s, 4) = arrCho(curCho, 4) 'Dien giai
ArrKq(s, ColTkNo) = arrCho(curCho, 7) ' TK No
ArrKq(s, ColTkCo) = arrNhan(curNhan, 7) ' TK Co
ArrKq(s, 7) = SLChia 'So tien
' If arrCho(curCho, 6) > 0 Then
' ArrKQ(s, 14) = arrCho(curCho, 10) 'MaKH
' ArrKQ(s, 15) = arrCho(curCho, 11) 'TenKH
' ArrKQ(s, 16) = Round(arrCho(curCho, 6) * ArrKQ(s, 7), 0) 'ST VND
' End If
curSLChoDu = curSLChoDu - SLChia
curSLNhanThieu = curSLNhanThieu - SLChia
s = s + 1
Loop
SoDong = s - 1
GanArr
End Sub
'Phan code duoi day it khi dung
'*********************************************
Sub TinhToan06()
curCho = 0: curNhan = 0: s = 1
curSLNhanThieu = 0: curSLChoDu = 0: SLChia = 0
'With Sheets("NKC")
'***---------------------------------------------------------
'Phan nay la nhieu no nhieu co vµ tat ca la so <0
Do While Not (curCho = UBound(arrCho) And curSLChoDu = 0)
If curSLChoDu = 0 Then
curCho = curCho + 1
curSLCho = arrCho(curCho, 8)
curSLChoDu = curSLCho
End If
If curSLNhanThieu = 0 Then
curNhan = curNhan + 1
curSLNhan = arrNhan(curNhan, 9)
curSLNhanThieu = curSLNhan
End If
If curSLChoDu >= curSLNhanThieu Then 'lay so < lon hon
SLChia = curSLChoDu
Else
SLChia = curSLNhanThieu
End If
ArrKq(s, 1) = arrCho(curCho, 1) 'Ngay HT
ArrKq(s, 2) = sSoCT 'SoCT
ArrKq(s, 3) = arrCho(curCho, 3) 'NgayCT
ArrKq(s, 4) = arrCho(curCho, 4) 'Dien giai
ArrKq(s, ColTkNo) = arrCho(curCho, 7) ' TK No
ArrKq(s, ColTkCo) = arrNhan(curNhan, 7) ' TK Co
ArrKq(s, 7) = SLChia 'So tien
If arrCho(curCho, 6) > 0 Then 'Ti gia
ArrKq(s, 14) = arrCho(curCho, 10) 'MaKH
ArrKq(s, 15) = arrCho(curCho, 11) 'TenKH
ArrKq(s, 16) = Round(ArrKq(s, 7) * arrCho(curCho, 6), 0) 'VND
End If
curSLChoDu = curSLChoDu - SLChia
curSLNhanThieu = curSLNhanThieu - SLChia
s = s + 1
Loop
SoDong = s - 1
GanArr
End Sub

Sub TinhToan02()
'Truong hop nay danh cho 1N va many C - Dem>2
SoDong = UBound(arrNhan)
n = 1 '1 No
For i = 1 To SoDong
For k = 1 To 4
ArrKq(i, k) = arrNhan(i, k) '4 cot dau
Next k
For k = 14 To 16
ArrKq(i, k) = arrNhan(i, k - 4) '3 cot sau
Next k
ArrKq(i, ColTkNo) = arrCho(n, 7) 'TKNo
ArrKq(i, ColTkCo) = arrNhan(i, 7) 'TKCo
ArrKq(i, 7) = arrNhan(i, 9) 'So tien
If arrNhan(i, 6) > 0 Then
ArrKq(i, 14) = arrNhan(i, 10) 'MaKH
ArrKq(i, 15) = arrNhan(i, 11) 'TenKH
ArrKq(i, 16) = Round(arrNhan(i, 6) * ArrKq(i, 7), 0) 'ST VND
End If
Next i
GanArr
End Sub
Sub TinhToan03()
'Truong hop nay danh cho 1C va many N - Dem>2
'TH nay nguoc voi TinhToan02 - be care Tuan
SoDong = UBound(arrCho)
n = 1 '1 No
For i = 1 To SoDong
For k = 1 To 4
ArrKq(i, k) = arrCho(i, k) '4 cot dau
Next k
ArrKq(i, ColTkNo) = arrCho(i, 7) 'TKNo
ArrKq(i, ColTkCo) = arrNhan(n, 7) 'TKCo
ArrKq(i, 7) = arrCho(i, 8) 'So tien
If arrCho(i, 6) > 0 Then
ArrKq(i, 14) = arrCho(i, 10) 'MaKH
ArrKq(i, 15) = arrCho(i, 11) 'TenKH
ArrKq(i, 16) = Round(arrCho(i, 6) * ArrKq(i, 7), 0) 'ST VND
End If
Next i
GanArr
End Sub
Sub TinhToan04()
' TH neu so TK No = So TK Co, STien No(1)=sotienco(1), SotienNo(end)=sotienco(end)
'MsgBox "OK"
SoDong = UBound(arrCho)
For i = 1 To SoDong
For k = 1 To 4
ArrKq(i, k) = arrCho(i, k) '4 cot dau
Next k
ArrKq(i, ColTkNo) = arrCho(i, 7) 'TKNo
ArrKq(i, ColTkCo) = arrNhan(i, 7) 'TKCo
ArrKq(i, 7) = arrCho(i, 8) 'So tien
If arrCho(i, 6) > 0 Then
ArrKq(i, 14) = arrCho(i, 10) 'MaKH
ArrKq(i, 15) = arrCho(i, 11) 'TenKH
ArrKq(i, 16) = Round(arrCho(i, 6) * ArrKq(i, 7), 0) 'ST VND
End If
Next i
GanArr
End Sub
Sub TinhToan07()
' TH neu co nhieu TK No va khong co TK Co
SoDong = UBound(arrCho)
For i = 1 To SoDong
For k = 1 To 4
ArrKq(i, k) = arrCho(i, k) '4 cot dau
Next k
For k = 10 To 3
ArrKq(i, k) = arrCho(i, k) '4 cot sau
Next k
ArrKq(i, ColTkNo) = arrCho(i, 7) 'TKNo
ArrKq(i, ColTkCo) = "" 'TKCo
ArrKq(i, 7) = arrCho(i, 8) 'So tien
If arrCho(i, 6) > 0 Then
ArrKq(i, 14) = arrCho(i, 10) 'MaKH
ArrKq(i, 15) = arrCho(i, 11) 'TenKH
ArrKq(i, 16) = Round(arrCho(i, 6) * ArrKq(i, 7), 0) 'ST VND
End If
Next i
GanArr
End Sub
Sub TinhToan08()
' TH neu co nhieu TK Co va khong co TK No
SoDong = UBound(arrNhan)
n = 1 '1 No
For i = 1 To SoDong
For k = 1 To 4
ArrKq(i, k) = arrNhan(i, k) '4 cot dau
Next k
For k = 10 To 13
ArrKq(i, k) = arrNhan(i, k) '4 cot sau
Next k
ArrKq(i, ColTkNo) = "" 'arrCho(n, 7) 'TKNo
ArrKq(i, ColTkCo) = arrNhan(i, 7) 'TKCo
ArrKq(i, 7) = arrNhan(i, 9) 'So tien
If arrNhan(i, 6) > 0 Then
ArrKq(i, 14) = arrNhan(i, 10) 'MaKH
ArrKq(i, 15) = arrNhan(i, 11) 'TenKH
ArrKq(i, 16) = Round(arrNhan(i, 6) * ArrKq(i, 7), 0) 'ST VND
End If
Next i
GanArr
End Sub
Sub TaoSoCtNew()
Dim endR&, i&, s&, sTmp$, SoDong&
Dim Arr(), ArrKq()
Const RowEnd = 400000
With Sheets("NKC-Tmp")
.AutoFilterMode = False
endR = .Cells(RowEnd, 2).End(3).Row
Arr = .Range("A8:I" & endR).Value
End With
ReDim ArrKq(1 To UBound(Arr), 1 To 9)
s = 1: SoDong = 0
sTmp = "xxxxx"
For i = 1 To UBound(Arr)
If i > 1 Then sTmp = Arr(i - 1, 2)
If CStr(Arr(i, 2)) <> CStr(sTmp) Then SoDong = SoDong + 1
If Len(Arr(i, 7)) > 0 Then
ArrKq(s, 1) = Arr(i, 1)
ArrKq(s, 2) = Right("0000" & SoDong, 5) & ";" & Arr(i, 2)
ArrKq(s, 3) = Arr(i, 3)
ArrKq(s, 7) = CStr(Arr(i, 7))
ArrKq(s, 4) = Arr(i, 4)
ArrKq(s, 5) = Arr(i, 5)
ArrKq(s, 6) = Arr(i, 6)
ArrKq(s, 8) = Arr(i, 8) * 1
ArrKq(s, 9) = Arr(i, 9) * 1
s = s + 1
End If
Next i
If s Then
With Sheets("NKCGoc")
.Range("A3:I" & endR).ClearContents
.[A3].Resize(s, 9) = ArrKq
End With
End If
Erase Arr(), ArrKq()
End Sub
Cảm ơn bạn rất nhiều!!!

Bài của bạn không cùng chủ đề bài này, bạn nên lập chủ đề riêng của bạn nhé.

HUONGHCKT · 11/11/21

dương hằng 247 đã viết:
Mình xin lỗi, mình cũng đang bị lỗi khi sử dụng 1 file VBA, nhờ bạn xem giúp, lỗi error 13 đoạn code như sau (khi bấm debug thì nó ra chỗ dòng màu đỏ):

Theo tôi, tốt nhất và nhanh nhất là bạn đưa file giả định của bạn nên (nếu file có nhiều vấn đề nhạy cảm thì chí ít cũng được 15-20 dòng), thì sẽ có nhiều thành viên xem và ai biết thì họ sẵn sàng giúp cho bạn thôi.
Chứ bạn đưa code này nên có file thử nghiệm đâu mà biết sai, lỗi ỏ chỗ nào đâu mà sửa.
P/S: Lần sau nếu đưa code nên bạn nên để giữa 2 dấu []

Bài đã được tự động gộp: 11/11/21

lvh1064 đã viết:
Bạn có thể giải thích cho mình hiểu câu lệnh này không Lr = .Cells(Rows.Count, 3).End(x1Up).Row, suy nghĩ không ra được, Cám ơn bạn nhiều nhé.

Câu lệnh Lr = .Cells(Rows.Count, 3).End(x1Up).Row là tìm dòng cuối có dữ liệu của cột 3.
Rows.count= dòng cuối của sheets= 1 XXX XXX dòng, 3 là cột 3 (cột C); End(xlup) là tìm dưới lên; row là để chỉ số dòng.
Bạn gõ từ khóa "tìm dòng cuối có dữ liệu bằngVBA" thì có cả tràng giang đại hải kết quả

SA_DQ · 12/11/21

lvh1064 đã viết:
Bạn có thể giải thích cho mình hiểu câu lệnh này không Lr = .Cells(Rows.Count, 3).End(x1Up).Row, suy nghĩ không ra được, Cám ơn bạn nhiều nhé.

Vì trước tiên dòng lệnh này nằm giữa 2 dòng lệnh

Mã:

   With Sheet2 ' . . . . .  . End With

Cho nên mình giải thích thêm cặp lệnh này 1 cách nôm na nha:
Mình hay gọi mệnh đề đầu của cặp là tuyên cáo của chương trình sẽ làm việc với đối tượng nào đó trong suốt quá trình chưa gặp mệnh đề thứ 2; Đối tượng mà tuyên cáo đem ra mần ở đây là Sheet2. (Vì trong file của chủ bài đăng đã không gán tên thường gọi cho các trang tính thân iêu của mình, nên đó là tên cúng cơm mà khi mới sinh ra Excel đã gán cho nó

)
Bộ 'tuyên cáo' này giúp cho người viết cũng như người đọc tiện hơn trong việc kiểm nghiệm & thẩm định chương trình(!)
Các mệnh đề lệnh được bao trong tuyên cáo thường có các dấu "."để thay cho đối tượng đang bị/được 'Mần thịt'
1 khi muốn diễn dịch từ ngôn ngữ VBA sang tiếng địa phương, ta thường nên dịch từ phải qua trái, như sau
Lấy dòng thuộc ô cuối nhất của cột 'C (thuộc trang (tính) đã tuyên cáo) có dữ liệu đem ấn (gán) vô tham biến 'Lr' (đã khai báo)
(Ở đây phương thức .End(. . . ) đã giúp ta tìm dòng cuối có dữ liệu ở cột thứ 3)
$$$$@

Hoàng Tuấn 868 đã viết:
Bài của bạn không cùng chủ đề bài này, bạn nên lập chủ đề riêng của bạn nhé.

Có khi đó là người 'rất' quen đó bạn; Hãy xem xét & giúp bạn í đi!

SA_DQ · 12/11/21

dương hằng 247 đã viết:
Mình xin lỗi, mình cũng đang bị lỗi khi sử dụng 1 file VBA, nhờ bạn xem giúp, lỗi error 13 đoạn code như sau (khi bấm debug thì nó ra chỗ dòng màu đỏ):

(1) Trong bài đăng của bạn không có dòng nào được tô đỏ cả, là sao? Hay bạn đang tìm cách để nhanh chóng tiến tới 30 bài viết, ngõ hầu tham gia quảng cáo này nọ?
(2) Bạn đăng Code nhưng lại không cho vô thẻ [ PHP ]. . . . . [ /php] hay [ Code ]. . . .[/code] nên quá khó xem, hay cũng nhằm (1) nêu trên?

(3) Đi vô chi tiết:
Trong macro sau:

Mã:

Sub TaoRng()
 Set Wf = WorksheetFunction
 iRow = 2                            'Dòng Dàu NKC   '
 Sheets("NKC").Range("A" & iRow & ":P" & RowEnd).ClearContents
 With Sheets("Tmp")
    endR = .Range("A" & RowEnd).End(xlUp).Row
    ArrTK = .Range(.Cells(2, 14), .Cells(U, 16)).Value  '???  '
 End With
 ' .   .   .   .    .    .    .    .                 '
 End Sub

Bạn thử kiểm tham biến 'U' chưa, & nếu thử rồi thì nó có lớn hơn con số 0 hay là không?
Mình biết, tham biến này bạn khai báo dùng chung & có thể macro khác trước khi gọi thằng TaoRng này đã gán trị cho 'U', nhưng macro đó bạn không/chưa chưng ra là mục đích gì?

. . . . . .
/-(ẹn gặp bạn ở 1 nơi mới, theo gợi ý từ #10

lvh1064 · 12/11/21

Hoàng Tuấn 868 đã viết:
Nếu bạn không dùng file của mình thì để mình bỏ đi nhé.

Hay lắm, rất hay và gọn nhưng áp dụng cụ thể vào file mình đang làm thì báo lỗi nên nhờ chỉ lỗi giùm. Cám ơn nhé

Hoàng Tuấn 868 · 12/11/21

lvh1064 đã viết:
Hay lắm, rất hay và gọn nhưng áp dụng cụ thể vào file mình đang làm thì báo lỗi nên nhờ chỉ lỗi giùm. Cám ơn nhé

Bạn không cho biết lỗi như thế nào thì chỉ sao đây. (Bạn nên đưa file có lỗi lên).

lvh1064 · 12/11/21

lvh1064 đã viết:
Bạn có thể giải thích cho mình hiểu câu lệnh này không Lr = .Cells(Rows.Count, 3).End(x1Up).Row, suy nghĩ không ra được, Cám ơn bạn nhiều nhé.

Cám ơn bạn nhiều, mình đã tìm ra chổ sai của đoạn code rồi, đó là End(xlup) mà mình viết End(x1up). Chân thành cám ơn bạn nhé.

Tạo Macro nhập liệu

Thành viên mới

File đính kèm

Zalo 0986997214

File đính kèm

Đăng ký hôm qua

Đăng ký hôm qua

File đính kèm

Thành viên mới

Zalo 0986997214

Thành viên mới

Đăng ký hôm qua

Thành viên mới

Đăng ký hôm qua

Zalo 0986997214

/(hông là gì!

/(hông là gì!

Thành viên mới

Đăng ký hôm qua

Thành viên mới

Facebook

Group