Copy dữ liệu từ sheet này sang sheet tạo thành database (1 người xem)

[dolly]

Nhờ các anh chị giúp đỡ em làm bài sau ạ.

- Có 2 sheet Input và Database trong đó Input sẽ nhập dữ liệu hàng ca. Database sẽ tổng hợp dữ liệu của 1 thời kì (tháng, năm)
- Tạo 1 nút tổng hợp để cuối mỗi ca những dữ liệu trong sheet input sẽ chuyển sang sheet database theo nguyên tắc: dữ liệu trong ô màu trắng được copy sang còn dữ liệu trong ô màu cam sẽ được lập lại như ví dụ
- Các ca tiếp theo cứ như thế

 

[ndu96081631]

Nhờ các anh chị giúp đỡ em làm bài sau ạ.

- Có 2 sheet Input và Database trong đó Input sẽ nhập dữ liệu hàng ca. Database sẽ tổng hợp dữ liệu của 1 thời kì (tháng, năm)
- Tạo 1 nút tổng hợp để cuối mỗi ca những dữ liệu trong sheet input sẽ chuyển sang sheet database theo nguyên tắc: dữ liệu trong ô màu trắng được copy sang còn dữ liệu trong ô màu cam sẽ được lập lại như ví dụ
- Các ca tiếp theo cứ như thế

Thí nghiệm với code này xem:

Sub Main()
  Dim wks_In As Worksheet, wks_Out As Worksheet
  Dim Arr(), sArray, Item(1 To 8), tmp
  Dim lR As Long, lC As Long, n As Long
  On Error Resume Next
  Set wks_In = Worksheets("Input")
  Set wks_Out = Worksheets("Data")
  With wks_In
    sArray = .Range("A8:C1000").Value
    Item(1) = .Range("B3").Value
    Item(2) = .Range("B1").Value
    Item(4) = .Range("H1").Value
    Item(5) = .Range("H2").Value
    Item(6) = .Range("E2").Value
    Item(7) = .Range("E3").Value
    Item(8) = .Range("B2").Value
  End With
  ReDim Arr(1 To UBound(sArray, 1), 1 To 10)
  For lR = 1 To UBound(sArray, 1)
    If Not IsEmpty(sArray(lR, 1)) Then
      tmp = sArray(lR, 1)
      n = n + 1
      For lC = 1 To 8
        If lC <> 3 Then Arr(n, lC) = Item(lC)
      Next
      Arr(n, 3) = sArray(lR, 2)
      Arr(n, 9) = sArray(lR, 1)
      Arr(n, 10) = sArray(lR, 3)
    End If
  Next
  If n Then
    With wks_Out
      .AutoFilterMode = False
      .Range("A60000").End(xlUp).Offset(1).Resize(n, 10).Value = Arr
    End With
    With wks_In
      .Range("A8:C1000").ClearContents
      Union(.[B1:B3], .[E2:F3], .[H1:H2]).ClearContents
    End With
  End If
End Sub