quykh
Chim non
- Tham gia
 - 7/9/11
 
- Bài viết
 - 381
 
- Được thích
 - 46
 
- Giới tính
 - Nữ
 
- Nghề nghiệp
 - Công Nhân
 




Mình có file báo cáo tháng này, mong các bạn giúp đỡ.File này bạn HYEN17 đã làm cho mình, nhưng mình thấy chưa đúng(Số lượng nhập, xuất trong tháng vẫn không đúng theo sheet chi tiết)




Vẫn không đúng bạn ơi! (ví dụ như BKT-1 trong tháng 1 đâu có nhập cái nào đâu mà có 120 cái). Ý của mình là chỉnh sửa lại trong code, để qua sheet Report cho nó đúng kìa.
Sub BCThg(Thg As Byte)
 Dim DatD As Date, DatC As Date
 Dim Sh As Worksheet, Rng As Range, sRng As Range, vRg As Range, Cls As Range, Cll As Range
 Dim SoNg As Integer, Jj As Integer, Col As Integer, NX As Integer
 Dim MyAdd As String
 
 Set Sh = ThisWorkbook.Worksheets("Report")
 Jj = Sh.[b6].CurrentRegion.Rows.Count       '<=|'
 Sh.[e6].Resize(Jj, 3).ClearContents         '<=|'
 Col = [iu5].End(xlToLeft).Column
 Range("E8").Resize(, Col).Copy
1 'Chép Tòn Nam Truóc'
 Sh.Range("E6").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
   False, Transpose:=True
 Application.CutCopyMode = False
 Set Rng = Range([a8], [A65500].End(xlUp))
 Rng.NumberFormat = "mm/dd/yyyy"
 If Thg > 1 Then
2 'Chép Tòn Các Tháng Truóc'
   DatD = DateSerial(Year(Date), 1, 1)
   DatC = DateSerial(Year(Date), Thg, 1)
   SoNg = DatC - DatD
   For Jj = 0 To SoNg - 1
      Set sRng = Rng.Find(Format(DatD + Jj, "mm/dd/yyyy"), , xlValues, xlWhole)
      If Not sRng Is Nothing Then
         MyAdd = sRng.Address
         Do
            If sRng.Row < 22 Then NX = 1 Else NX = -1
            Set vRg = sRng.Offset(, 4).Resize(, Col).SpecialCells(xlCellTypeConstants, 3)
            If Not vRg Is Nothing Then
               For Each Cls In vRg
                  For Each Cll In Sh.Range(Sh.[b6], Sh.[b65500].End(xlUp))
                     If Cll.Value = Cells(5, Cls.Column).Value Then
                        With Cll.Offset(, 3)
                           .Value = .Value + NX * Cls.Value
                        End With
                     End If
                  Next Cll
               Next Cls
            End If
            Set sRng = Rng.FindNext(sRng)
         Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
      End If
   Next Jj
 End If
3 'Chép Só Lieu Cua Tháng'
   DatD = IIf(Thg = 1, DateSerial(Year(Date), 1, 1), DatC)
   DatC = IIf(Thg = 1, DateSerial(Year(Date), 2, 1), DateSerial(Year(Date), Thg + 1, 1))
   SoNg = DatC - DatD
   For Jj = 0 To SoNg - 1
      Set sRng = Rng.Find(Format(DatD + Jj, "mm/dd/yyyy"))
      If Not sRng Is Nothing Then
         MyAdd = sRng.Address
         Do
            If sRng.Row < 22 Then NX = 1 Else NX = 2
            Set vRg = sRng.Offset(, 4).Resize(, Col).SpecialCells(xlCellTypeConstants, 3)
            If Not vRg Is Nothing Then
               For Each Cls In vRg
               
                  For Each Cll In Sh.Range(Sh.[b6], Sh.[b65500].End(xlUp))
                     If Cll.Value = Cells(5, Cls.Column).Value Then
                        With Cll.Offset(, 3 + NX)
                           .Value = .Value + Cls.Value
                        End With
                     End If
                  Next Cll
               
               Next Cls
            End If
            Set sRng = Rng.FindNext(sRng)
         Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
      End If
   Next Jj
   
   Sh.Select
End Sub
	quykh đã viết:(1) Cho mình hỏi khi chép qua Report mình không muốn nó có đường gạch đậm thì chỉnh code sao hả bạn?
(2) Trong code của bạn định dạng là mm/dd/yyyy mình chỉnh lại dd/mm/yyyy có ảnh hưởng gì không bạn? Bạn cho phép mình là bạn của bạn để học hỏi thêm nhe?
   Next Jj
   Rng.NumberFormat = "DD/mm/yyyy"    '<=|'
   Sh.Select
End Sub
	Bạn cho mình hỏi thêm nhe :
3/ mình chèn thêm dòng để nhập thêm hoặc xuất thêm.
4/mình muốn thêm mặt hàng nữa. thì có được không bạn?
quykh đã viết:Cám ơn Bạn nhiều. Nhưng cho mình hỏi thế thì mình có thể tạo một sheet" tổng hợp" để đưa số liệu tồn cuối của 12 tháng qua được không bạn. Chứ sheet " chi tiết" nhìn hơi "rối".
Sub CopyValue()
    Rows("9:18").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
End Sub
	Sub BCThg(Thg As Byte)
 On Error GoTo GPE
 Dim DatD As Date, DatC As Date
 Dim Sh As Worksheet, Rng As Range, sRng As Range, vRg As Range, Cls As Range, Cll As Range
 Dim SoNg As Integer, Jj As Integer, Col As Integer, NX As Integer
 Dim MyAdd As String
 
 Set Sh = ThisWorkbook.Worksheets("Bao Cao")
 Jj = Sh.[b6].CurrentRegion.Rows.Count
  Sh.[e6].Resize(Jj, 3).ClearContents
 Col = [iu5].End(xlToLeft).Column
 Range("E8").Resize(, Col).Copy
1 'Chép Tòn Nam Truóc'
 Sh.Range("E6").PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, SkipBlanks:= _
   False, Transpose:=True
 Application.CutCopyMode = False
 Set Rng = Range([a8], [A9999].End(xlUp))
 Rng.NumberFormat = "mm/dd/yyyy"
 If Thg > 1 Then
2 'Chép Tòn Các Tháng Truóc'
   DatD = DateSerial(Year(Date), 1, 1)
   DatC = DateSerial(Year(Date), Thg, 1)
   SoNg = DatC - DatD
   For Jj = 0 To SoNg - 1
      Set sRng = Rng.Find(Format(DatD + Jj, "mm/dd/yyyy"), , xlValues, xlWhole)
      If Not sRng Is Nothing Then
         MyAdd = sRng.Address
         Do
            If sRng.Row < 18 Then NX = 1 Else NX = -1
            Set vRg = sRng.Offset(, 4).Resize(, Col).SpecialCells(xlCellTypeConstants, 3)
            If Not vRg Is Nothing Then
               For Each Cls In vRg
                  For Each Cll In Sh.Range(Sh.[b6], Sh.[b65500].End(xlUp))
                     If Cll.Value = Cells(5, Cls.Column).Value Then
                        With Cll.Offset(, 3)
                           .Value = .Value + NX * Cls.Value
                        End With
                     End If
                  Next Cll
               Next Cls
            End If
            Set sRng = Rng.FindNext(sRng)
         Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
      End If
   Next Jj
 End If
3 'Chép Só Lieu Cua Tháng'
'  **    **    **    **    ** '
    Rows("9:18").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
'  **    **    **    **    ** '
   DatD = IIf(Thg = 1, DateSerial(Year(Date), 1, 1), DatC)
   DatC = IIf(Thg = 1, DateSerial(Year(Date), 2, 1), DateSerial(Year(Date), Thg + 1, 1))
   SoNg = DatC - DatD
   For Jj = 0 To SoNg - 1
      Set sRng = Rng.Find(Format(DatD + Jj, "mm/dd/yyyy"))
      If Not sRng Is Nothing Then
         MyAdd = sRng.Address
         Do
            If sRng.Row < 18 Then NX = 1 Else NX = 2
            
            Set vRg = sRng.Offset(, 4).Resize(, Col).SpecialCells(xlCellTypeConstants, 3)
            If Not vRg Is Nothing Then
               For Each Cls In vRg
                  For Each Cll In Sh.Range(Sh.[b6], Sh.[b65500].End(xlUp))
                     If Cll.Value = Cells(5, Cls.Column).Value Then
                        With Cll.Offset(, 3 + NX)
                           .Value = .Value + Cls.Value
                        End With
                     End If
                  Next Cll
               Next Cls
            End If
            Set sRng = Rng.FindNext(sRng)
         Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
      End If
   Next Jj
   Rng.NumberFormat = "DD/mm/yyyy"
   Sh.Select
ERR_:          Exit Sub
GPE:
   Select Case Err
   Case 1004
      Resume Next
   Case Else
      MsgBox Err, , Error:            GoTo ERR_
   End Select
End Sub
	Dư là sao hả bạn! Thế bạn có thể rút gọn lại không?
(1) file ở bài 12 là chi tiết từng ngày, mình đâu cần từng ngày.
Chỉ cần từng tháng thôi.
(2) Bạn có thể gửi file gộp được không?
Cho em hỏi có cách nào để tự động cập nhập số dòng khi chèn không ạ? Chứ cứ khi chèn dòng lại chỉnh sửa trong CODE.
quykh đã viết:Bạn ơi, mình quen định dạng theo ngày tháng năm (dd/mm/yyyy) rồi. Bạn có thể chỉnh lại file của bạn theo ngày tháng năm được không? Cám ơn bạn nhiều!
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [T1]) Is Nothing Then
   Dim Sh As Worksheet, Rng As Range, sRng As Range, vRg As Range, Cls As Range, Cll As Range
   Dim Rws As Long, Thg As Byte, SoNg As Byte, jJ As Byte, NX As Byte
   Dim NgD As Date, MyAdd As String
   
   Rws = [b5].CurrentRegion.Rows.Count
   [q6].Resize(Rws, 3).ClearContents
40 'Chép Tòn Dàu Tháng:'
   Thg = Target.Value
   [d5].Offset(1, Thg).Resize(Rws).Copy Destination:=[q6]
   Application.CutCopyMode = False
41 'Chép Só Lieu Cua Tháng'
   NgD = DateSerial(Year(Date), Thg, 1)
   SoNg = Day(DateSerial(Year(Date), Thg + 1, 0))
   Set Sh = ThisWorkbook.Worksheets("CSDL")
   Set Rng = Sh.Range(Sh.[a8], Sh.[a65500].End(xlUp))
   Rng.NumberFormat = "MM/dd/yyyy"
   On Error GoTo XL_Loi
   
   For jJ = 0 To SoNg
      Set sRng = Rng.Find(Format(NgD + jJ, "mm/dd/yyyy"), , xlValues, xlWhole)
      If Not sRng Is Nothing Then
         MyAdd = sRng.Address
         Do
            If sRng.Row < 50 Then NX = 16 Else NX = 17
            Set vRg = sRng.Offset(, 4).Resize(, Rws).SpecialCells(xlCellTypeConstants, 3)
            If Not vRg Is Nothing Then
               For Each Cls In vRg
                  For Each Cll In Range([b6], [b65500].End(xlUp))
                     If Cll.Value = Sh.Cells(5, Cls.Column).Value Then
                        With Cll.Offset(, NX)
                           .Value = .Value + Cls.Value
                        End With
                     End If
                  Next Cll
               Next Cls
            End If
            Set sRng = Rng.FindNext(sRng)
         Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
      End If
   Next jJ
42 'Chép Tòn Cuói Tháng:'
   If Thg = 12 Then                    '<=|'
      Thg = 0:                         [f6].Resize(Rws, 11).ClearContents
   End If
   [e6].Offset(, Thg).Resize(Rws).Value = [t6].Resize(Rws).Value
   Rng.NumberFormat = "dd/mm/yyyy"     '<=|'
 End If
Err__:                                  Exit Sub
XL_Loi:
   Select Case Err
   Case 1004
      Resume Next
   Case Else
      MsgBox Err, , Error:             GoTo Err__
   End Select
End Sub