Code VBA bị lỗi in phiếu xuất kho
- Thread starter dinhduy
- Ngày gửi
Cám ơn anh nhiều nha, có bạn nước ngoài đã sửa giúp mình ah.
Đây là đoạn CODE bạn ấy
Mã:
Sub TimPhieu()
Dim tmpArr, KqArr, Fm
Dim irow As Long, Rw As Long, k As Long
Dim Val As String
Val = Sheet04.Range("T2")
Lrw = Sheet03.Range("C" & Sheet03.Rows.Count).End(xlUp).Row
Rw = Sheet03.Range("C2:C" & Lrw).Find(Val, Sheet03.Range("C2"), xlFormulas, xlWhole).Row
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Set Fm = Application.WorksheetFunction
With Sheet04
.[E8] = Fm.VLookup(.[T2], [XK], 4, 0)
.[P8] = Fm.VLookup(.[T2], [XK], 2, 0)
.[S8] = Fm.VLookup(.[T2], [XK], 2, 0)
.[U8] = Fm.VLookup(.[T2], [XK], 2, 0)
.[C10] = Fm.VLookup(.[T2], [XK], 5, 0)
.[l19] = Fm.VLookup(.[T2], [XK], 13, 0)
End With
tmpArr = Sheet03.Range("C" & Rw & ":O" & Lrw).Value
ReDim KqArr(1 To UBound(tmpArr, 1), 1 To 20)
For irow = 1 To UBound(tmpArr, 1)
If tmpArr(irow, 1) = Val Then
k = k + 1
KqArr(k, 1) = k
KqArr(k, 2) = tmpArr(irow, 7)
KqArr(k, 9) = tmpArr(irow, 8)
KqArr(k, 11) = tmpArr(irow, 10)
KqArr(k, 13) = tmpArr(irow, 11)
KqArr(k, 15) = tmpArr(irow, 9)
KqArr(k, 20) = tmpArr(irow, 12)
End If
Next
Sheet04.Range("B11").Resize(7, 20).ClearContents
Sheet04.Range("B11").Resize(k, 20).Value = KqArr
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Upvote
0
Maika8008
Thành viên gạo cội
- Tham gia
- 12/6/20
- Bài viết
- 4,763
- Được thích
- 5,719
- Donate (Momo)
- Giới tính
- Nam
Cần bỏ đoạn này đi
Set Fm = Application.WorksheetFunction
With Sheet04
.[E8] = Fm.VLookup(.[T2], [XK], 4, 0)
.[P8] = Fm.VLookup(.[T2], [XK], 2, 0)
.[S8] = Fm.VLookup(.[T2], [XK], 2, 0)
.[U8] = Fm.VLookup(.[T2], [XK], 2, 0)
.[C10] = Fm.VLookup(.[T2], [XK], 5, 0)
.[l19] = Fm.VLookup(.[T2], [XK], 13, 0)
End With
Đã chạy vòng lặp trong mảng rồi thì đoạn đó chỉ làm chậm code. Sửa lại như sau:
Rich (BB code):
Sub TimPhieu()
Dim tmpArr, KqArr, Fm
Dim irow As Long, Rw As Long, k As Long
Dim Val As String
Val = Sheet04.Range("T2")
Lrw = Sheet03.Range("C" & Sheet03.Rows.Count).End(xlUp).Row
Rw = Sheet03.Range("C2:C" & Lrw).Find(Val, Sheet03.Range("C2"), xlFormulas, xlWhole).Row
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
tmpArr = Sheet03.Range("C" & Rw & ":O" & Lrw).Value
ReDim KqArr(1 To UBound(tmpArr, 1), 1 To 15)
For irow = 1 To UBound(tmpArr, 1)
If tmpArr(irow, 1) = Val Then
k = k + 1
KqArr(k, 1) = k
If k = 1 Then
With Sheet04
.[E8] = tmpArr(irow, 4)
.[P8] = tmpArr(irow, 2)
.[S8] = tmpArr(irow, 2)
.[U8] = tmpArr(irow, 2)
.[C10] = tmpArr(irow, 5)
.[l19] = tmpArr(irow, 13)
End With
End If
KqArr(k, 2) = tmpArr(irow, 7)
KqArr(k, 9) = tmpArr(irow, 8)
KqArr(k, 11) = tmpArr(irow, 10)
KqArr(k, 13) = tmpArr(irow, 11)
KqArr(k, 15) = tmpArr(irow, 9)
KqArr(k, 20) = tmpArr(irow, 12)
End If
Next
Sheet04.Range("B11").Resize(7, 20).ClearContents
Sheet04.Range("B11").Resize(k, 15).Value = KqArr
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Upvote
0
Em cám ơn anh rất nhiều nha, CODE đã được cải thiện đáng kể ah.
Upvote
0
Bài viết mới nhất
- Question
- Question
- Question
