Nhờ các Pro giúp mình với. Mình biết code không rành lắm. Muốn tạo phiếu Nhập khi nhấn Nút ghi thì ghia sang Sheet "DL" rồi nhập tiếp Phiếu tiếp theo nhưng bị ghi đè chứ không ghi dưới mẫu tin trước. Rất mong giúp đỡ.
'======= Loc nhung dong co du lieu thoa dieu kien => cap nhat sang Data
Dim arrDG(), arrTK(), C_TU As String ' C_TU la dieu kien loc
Dim endR As Long, i As Long, k As Long, s As Long, n As Long
Dim rngNo As Range, rngCo As Range, rngDG As Range
Sub Loc_PhieuNhap()
Application.ScreenUpdating = False
Dim WsN As Worksheet
Dim WsD As Worksheet
Set WsN = Sheets("PN")
Set WsD = Sheets("DL")
With WsN
.AutoFilterMode = False
endR = .Range("m100").End(xlUp).Row
C_TU = WsN.Range("D5")
Set rngDG = .Range("a9:m" & endR)
Set rngNo = .Range("m9:m" & endR)
Set rngCo = .Range("n9:n" & endR)
End With
Dim rngData As Range
s = 0
Dim arrKQ(1 To 100, 1 To 13) ' ==== "TO" bao nhieu cot tren phieu can copy sang
Set rngData = Union(rngNo, rngCo)
arrTK = rngData.Value
arrDG = rngDG.Value
For i = 1 To UBound(arrTK)
'Copy du lieu co dieu kien . Bao nhieu cot thi bay nhieu dong lenh
If arrTK(i, 1) = C_TU Then
s = s + 1
arrKQ(s, 1) = arrDG(i, 1)
arrKQ(s, 2) = arrDG(i, 2)
arrKQ(s, 3) = arrDG(i, 3)
arrKQ(s, 4) = arrDG(i, 4)
arrKQ(s, 5) = arrDG(i, 5)
arrKQ(s, 6) = arrDG(i, 6)
arrKQ(s, 7) = arrDG(i, 7)
arrKQ(s, 8) = arrDG(i, 8)
arrKQ(s, 9) = arrDG(i, 9)
arrKQ(s, 10) = arrDG(i, 10)
arrKQ(s, 11) = arrDG(i, 11)
arrKQ(s, 12) = arrDG(i, 12)
arrKQ(s, 13) = arrDG(i, 13)
End If
Next
If s = 0 Then Exit Sub
With WsD
With .Range("Bd")
'ActiveCell.Offset(Range("dem").Value, 0).Select
.Resize(s, 13) = arrKQ
End With
End With
Set rngData = Nothing
Erase arrTK, arrKQ, arrDG
Application.ScreenUpdating = True
End Sub
'======= Loc nhung dong co du lieu thoa dieu kien => cap nhat sang Data
Dim arrDG(), arrTK(), C_TU As String ' C_TU la dieu kien loc
Dim endR As Long, i As Long, k As Long, s As Long, n As Long
Dim rngNo As Range, rngCo As Range, rngDG As Range
Sub Loc_PhieuNhap()
Application.ScreenUpdating = False
Dim WsN As Worksheet
Dim WsD As Worksheet
Set WsN = Sheets("PN")
Set WsD = Sheets("DL")
With WsN
.AutoFilterMode = False
endR = .Range("m100").End(xlUp).Row
C_TU = WsN.Range("D5")
Set rngDG = .Range("a9:m" & endR)
Set rngNo = .Range("m9:m" & endR)
Set rngCo = .Range("n9:n" & endR)
End With
Dim rngData As Range
s = 0
Dim arrKQ(1 To 100, 1 To 13) ' ==== "TO" bao nhieu cot tren phieu can copy sang
Set rngData = Union(rngNo, rngCo)
arrTK = rngData.Value
arrDG = rngDG.Value
For i = 1 To UBound(arrTK)
'Copy du lieu co dieu kien . Bao nhieu cot thi bay nhieu dong lenh
If arrTK(i, 1) = C_TU Then
s = s + 1
arrKQ(s, 1) = arrDG(i, 1)
arrKQ(s, 2) = arrDG(i, 2)
arrKQ(s, 3) = arrDG(i, 3)
arrKQ(s, 4) = arrDG(i, 4)
arrKQ(s, 5) = arrDG(i, 5)
arrKQ(s, 6) = arrDG(i, 6)
arrKQ(s, 7) = arrDG(i, 7)
arrKQ(s, 8) = arrDG(i, 8)
arrKQ(s, 9) = arrDG(i, 9)
arrKQ(s, 10) = arrDG(i, 10)
arrKQ(s, 11) = arrDG(i, 11)
arrKQ(s, 12) = arrDG(i, 12)
arrKQ(s, 13) = arrDG(i, 13)
End If
Next
If s = 0 Then Exit Sub
With WsD
With .Range("Bd")
'ActiveCell.Offset(Range("dem").Value, 0).Select
.Resize(s, 13) = arrKQ
End With
End With
Set rngData = Nothing
Erase arrTK, arrKQ, arrDG
Application.ScreenUpdating = True
End Sub
File đính kèm
Lần chỉnh sửa cuối: