Thực hiện thẻ kho bằng macro, xin ý kiến góp ý của các bạn

[ChanhTQ@]

Tham khảo từ bài viết http://giaiphapexcel.com/forum/showthread.php?t=24866 , mình viết 1 macro tạo lập thẻ kho;

Vì là dân ngoại đạo, nên rất mong sự góp ý của các bạn gần xa để tiếp tục hoàn thiện

Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [c3]) Is Nothing Then
   Dim Rng As Range, sRng As Range:       Dim Sh As Worksheet
   Dim eRw As Long, Col As Byte:          Dim MyAdd As String
   Dim fDay As String, lDay As String
1
   Set Sh = Sheets("Ton"):                eRw = Sh.[A65500].End(xlUp).Row
   Set Rng = Sh.Range(Sh.[D1], Sh.[iv1].End(xlToLeft))
   Rng.NumberFormat = "M/d/yyyy"
   fDay = Format([A2].Value, "short date")
   lDay = Format([D2].Value, "short date")
   Set sRng = Rng.Find(fDay, , xlFormulas, xlWhole)
   If Not sRng Is Nothing Then
      Col = sRng.Column - 1:              Set sRng = Nothing
   End If
   Set Rng = Sh.Range(Sh.[A1], Sh.[A65500].End(xlUp))
   [f9].Value = Rng.Find(Target.Value).Offset(, Col)
2
   Set Sh = Sheets("NhXt"):               Set Rng = Sh.Range(Sh.[c1], Sh.[c65500].End(xlUp))
   Sh.Columns(1).NumberFormat = "m/d/yyyy"
   [a10].Resize(26, 7).ClearContents:     Set sRng = Rng.Find(Target.Value)
   If Not sRng Is Nothing Then
      MyAdd = sRng.Address
      Do
         If sRng.Offset(, -2) >= fDay And sRng.Offset(, -2) <= lDay Then
            With [c36].End(xlUp)
               .Offset(1) = sRng.Offset(, 2).Value
               .Offset(1, -2) = sRng.Offset(, -1).Value
               .Offset(1, -1) = sRng.Offset(, -2).Value
               .Offset(1, IIf(UCase$(sRng.Offset(, 1)) = "N", 1, 2)) _
                  = sRng.Offset(, 3).Value
            End With
         End If
         Set sRng = Rng.FindNext(sRng)
      Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
   End If
 End If
End Sub

(Sẽ bổ sung phiếu nhập xuất vật tư hàng hóa)

 

[ChanhTQ@]

Tiếp theo là macro dùng để kiểm kê hàng tồn kho vào thời điểm bất kì nào.

Giải thích thêm:
Trong bất cứ thời điểm nào, nếu bạn bấm nút lệnh tại 'Form', macro sau sẽ kiểm số hàng từ thời điểm kiểm kê lần trước & đối chiếu với số xuất nhập trong kỳ để cho ta số hàng tồn trong kho;

Số hàng tồn này sẽ được ghi vô cột cuối của 'Ton'

& từ giờ trở đi cột dữ liệu này là điểm mốc mới để làm thẻ kho.

Option Explicit
Sub KiemKe()
 Dim Sh As Worksheet, Rng As Range, sRng As Range, Clls As Range
 Dim eRw As Long, Col As Byte:         Dim fDat As Date, eDat As Date
 Dim SoNh As Double, SoXt As Double
 Dim CommText As String, MyAdd As String
 
 Sheets("Ton").Select:                 eRw = [A65500].End(xlUp).Row
 Col = [iV1].End(xlToLeft).Column:     fDat = Cells(1, Col).Value
 Set Rng = Cells.SpecialCells(xlCellTypeComments)
 CommText = Rng.Cells(1, 1).Comment.Text:          Rng.ClearComments
 eDat = Date
 With Cells(1, Col + 1)
   .Value = eDat:                      .AddComment
   .Comment.Visible = False:           .Comment.Text Text:=CommText
 End With
 
 Set Sh = Sheets("NhXt"):              Set Rng = Sh.Range(Sh.[c1], Sh.[c65500].End(xlUp))
 For Each Clls In Range([A2], [A65500].End(xlUp))
   SoNh = Cells(Clls.Row, Col).Value:  SoXt = 0
   Set sRng = Rng.Find(Clls, , xlFormulas, xlWhole)
   If Not sRng Is Nothing Then
      MyAdd = sRng.Address
      Do
         With sRng
            If .Offset(, -2).Value >= fDat And .Offset(, -2).Value < eDat Then
               If UCase$(.Offset(, 1)) = "N" Then
                  SoNh = SoNh + sRng.Offset(, 3)
               Else
                  SoXt = SoXt + .Offset(, 3)
               End If
            End If
         End With
         Set sRng = Rng.FindNext(sRng)
      Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
   End If
   Cells(Clls.Row, Col + 1).Value = SoNh - SoXt
 Next Clls
End Sub

( Các bạn khoan xem 2 trang tính cuối nha; Sẽ giới thiệu vào bài sắp tới - Xin cảm ơn!)

 

[ChanhTQ@]

Và đây là cách macro giải quyết cho http://giaiphapexcel.com/forum/showthread.php?t=2

(http://giaiphapexcel.com/forum/showthread.php?t=24866#8)

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [E5]) Is Nothing Then
   Dim Sh As Worksheet, Rng As Range, sRng As Range
   Dim MaVT As String, MyAdd As String
   
   Set Sh = Sheets("DLieu")
   Set Rng = Sh.Range(Sh.[l1], Sh.[l1].End(xlDown))
   MaVT = Rng.Find(Target.Value, , xlFormulas, xlWhole).Offset(, -1).Value
   [j5].Value = "(" & MaVT & ")"
   Set Rng = Sh.Range(Sh.[D1], Sh.[D65500].End(xlUp))
   [B10].Resize([B65500].End(xlUp).Row, 8).ClearContents
   Set sRng = Rng.Find(MaVT)
   If Not sRng Is Nothing Then
      [e6].Value = sRng.Offset(, 3).Value:         MyAdd = sRng.Address
      Do
         With [e65500].End(xlUp).Offset(1)
            .Value = sRng.Offset(, 2):             .Offset(, -3).Value = sRng.Offset(, -3)
            If sRng.Offset(, 4) <> "" Then
               .Offset(, -2).Value = sRng.Offset(, -1)
               .Offset(, 2).Value = sRng.Offset(, 4)
            Else
               .Offset(, -1).Value = sRng.Offset(, -1)
               .Offset(, 3).Value = sRng.Offset(, 5)
            End If
            .Offset(, 4) = .Offset(, 2) - .Offset(, 3) + IIf(.Row = 10, 0, .Offset(-1, 4))
         End With
         Set sRng = Rng.FindNext(sRng)
      Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
   End If
 End If
End Sub

(Các bạn xem trong 2 trang tính sau cùng của file đính kèm của bài trên)

Chúc vui.