Tổng hợp dữ liệu

Bích Tỷ · 3/4/24

Dạ, em chào mọi người,

Em có một file có các sheet: W1,W2,W3,W4,W5 và sheet data_report.
Trong các sheet W1-5 thì có các cột: SỐ THẺ, HỌ VÀ TÊN VÀ BỘ PHẬN
Em cần tổng hợp dữ liệu từ các sheet này vào sheet data_report theo SỐ THẺ, HỌ VÀ TÊN VÀ BỘ PHẬN từ các sheet trên.
Em xin cảm ơn ạ

HieuCD · 3/4/24

Bích Tỷ đã viết:
Dạ, em chào mọi người,

Em có một file có các sheet: W1,W2,W3,W4,W5 và sheet data_report.
Trong các sheet W1-5 thì có các cột: SỐ THẺ, HỌ VÀ TÊN VÀ BỘ PHẬN
Em cần tổng hợp dữ liệu từ các sheet này vào sheet data_report theo SỐ THẺ, HỌ VÀ TÊN VÀ BỘ PHẬN từ các sheet trên.
Em xin cảm ơn ạ

Chạy code

Mã:

Sub XYZ()
  Dim aRow&(1 To 5), a(), b(), res(), dic As Object, sh As Worksheet
  Dim sR&, n&, i&, k&, ik&, j&, Total#
 
  Set dic = CreateObject("scripting.dictionary")
  Set sh = ThisWorkbook.Sheets("data_report")
 
  For n = 1 To 5
    aRow(n) = Sheets("W" & n).Range("A" & Rows.Count).End(xlUp).Row - 6
    sR = sR + aRow(n)
  Next n
  sR = sR + 1
  ReDim res(1 To sR, 1 To 10)
  For n = 1 To 5
    a = Sheets("W" & n).Range("A7").Resize(aRow(n), 6).Value
    b = Sheets("W" & n).Range("AD7").Resize(aRow(n)).Value
    j = n + 4
    For i = 1 To aRow(n)
      If dic.exists(a(i, 5)) = False Then
        k = k + 1
        dic.Add a(i, 5), k
        res(k, 1) = k
        res(k, 2) = a(i, 5)
        res(k, 3) = a(i, 6)
        res(k, 4) = a(i, 1)
      End If
      ik = dic(a(i, 5))
      res(ik, j) = res(ik, j) + b(i, 1)
      res(sR, j) = res(sR, j) + b(i, 1)
      res(ik, 10) = res(ik, 10) + b(i, 1)
      Total = Total + b(i, 1)
    Next i
  Next n
  k = k + 1
  res(k, 1) = "TOTAL"
  res(k, 10) = Total
  For j = 5 To 9
    res(k, j) = res(sR, j)
  Next j
  With Sheets("data_report")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 7 Then .Range("A8:L" & i).Clear
    .Range("A8").Resize(k, 10) = res
    .Range("A8").Resize(k, 10).Borders.LineStyle = 1
  End With
End Sub

Merge cell tự làm nhá

Bích Tỷ · 3/4/24

HieuCD đã viết:

Chạy code

Mã:

Sub XYZ()
  Dim aRow&(1 To 5), a(), b(), res(), dic As Object, sh As Worksheet
  Dim sR&, n&, i&, k&, ik&, j&, Total#
 
  Set dic = CreateObject("scripting.dictionary")
  Set sh = ThisWorkbook.Sheets("data_report")
 
  For n = 1 To 5
    aRow(n) = Sheets("W" & n).Range("A" & Rows.Count).End(xlUp).Row - 6
    sR = sR + aRow(n)
  Next n
  sR = sR + 1
  ReDim res(1 To sR, 1 To 10)
  For n = 1 To 5
    a = Sheets("W" & n).Range("A7").Resize(aRow(n), 6).Value
    b = Sheets("W" & n).Range("AD7").Resize(aRow(n)).Value
    j = n + 4
    For i = 1 To aRow(n)
      If dic.exists(a(i, 5)) = False Then
        k = k + 1
        dic.Add a(i, 5), k
        res(k, 1) = k
        res(k, 2) = a(i, 5)
        res(k, 3) = a(i, 6)
        res(k, 4) = a(i, 1)
      End If
      ik = dic(a(i, 5))
      res(ik, j) = res(ik, j) + b(i, 1)
      res(sR, j) = res(sR, j) + b(i, 1)
      res(ik, 10) = res(ik, 10) + b(i, 1)
      Total = Total + b(i, 1)
    Next i
  Next n
  k = k + 1
  res(k, 1) = "TOTAL"
  res(k, 10) = Total
  For j = 5 To 9
    res(k, j) = res(sR, j)
  Next j
  With Sheets("data_report")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 7 Then .Range("A8:L" & i).Clear
    .Range("A8").Resize(k, 10) = res
    .Range("A8").Resize(k, 10).Borders.LineStyle = 1
  End With
End Sub

Merge cell tự làm nhá

Trường hợp có 1 hoặc nhiều sheet bất kỳ trong 5 sheets W1-5 không có dữ liệu thì bị lỗi anh ạ. anh sửa giúp em ạ

LePhatHuy · 3/4/24

Bích Tỷ đã viết:
Trường hợp có 1 hoặc nhiều sheet bất kỳ trong 5 sheets W1-5 không có dữ liệu thì bị lỗi anh ạ. anh sửa giúp em ạ

Bạn dùng code sau của tui thử nhé.

Mã:

Sub TongHop()
    Dim strSQL As String, i As Integer
    Sheet1.Range("A8:K500").ClearContents
    For i = 1 To 5
         strSQL = strSQL & "Union All Select F5 As SoThe,F6 As HoVaTen,F1 As BoPhan,F30 As ThanhTien,'W" & i & "' As SheetName From [W" & i & "$A6:AD] Where F1 Is Not Null "
    Next
    strSQL = Right(strSQL, Len(strSQL) - 10)
    With CreateObject("ADODB.Connection")
        .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=No"""
        Sheet1.Range("B8").CopyFromRecordset .Execute("TRANSFORM Sum(ThanhTien) As TongTien Select SoThe,HoVaTen,BoPhan,Sum(ThanhTien) From (" & strSQL & ") Group By SoThe,HoVaTen,BoPhan Pivot SheetName")
    End With
End Sub

HieuCD · 3/4/24

Bích Tỷ đã viết:
Trường hợp có 1 hoặc nhiều sheet bất kỳ trong 5 sheets W1-5 không có dữ liệu thì bị lỗi anh ạ. anh sửa giúp em ạ

Thêm điều kiện có dữ liệu

Mã:

Sub XYZ()
  Dim aRow&(1 To 5), a(), b(), res(), dic As Object, sh As Worksheet
  Dim sR&, n&, i&, k&, ik&, j&, Total#
 
  Set dic = CreateObject("scripting.dictionary")
  Set sh = ThisWorkbook.Sheets("data_report")
 
  For n = 1 To 5
    aRow(n) = Sheets("W" & n).Range("A" & Rows.Count).End(xlUp).Row - 6
    If aRow(n) > 0 Then sR = sR + aRow(n)
  Next n
  sR = sR + 1
  ReDim res(1 To sR, 1 To 10)
  For n = 1 To 5
    If aRow(n) > 0 Then
      a = Sheets("W" & n).Range("A7").Resize(aRow(n), 6).Value
      b = Sheets("W" & n).Range("AD7").Resize(aRow(n)).Value
      j = n + 4
      For i = 1 To aRow(n)
        If dic.exists(a(i, 5)) = False Then
          k = k + 1
          dic.Add a(i, 5), k
          res(k, 1) = k
          res(k, 2) = a(i, 5)
          res(k, 3) = a(i, 6)
          res(k, 4) = a(i, 1)
        End If
        ik = dic(a(i, 5))
        res(ik, j) = res(ik, j) + b(i, 1)
        res(sR, j) = res(sR, j) + b(i, 1)
        res(ik, 10) = res(ik, 10) + b(i, 1)
        Total = Total + b(i, 1)
      Next i
    End If
  Next n
  k = k + 1
  res(k, 1) = "TOTAL"
  res(k, 10) = Total
  For j = 5 To 9
    res(k, j) = res(sR, j)
  Next j
  With Sheets("data_report")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 7 Then .Range("A8:L" & i).Clear
    If k > 1 Then
      .Range("A8").Resize(k, 10) = res
      .Range("A8").Resize(k, 10).Borders.LineStyle = 1
    End If
  End With
End Sub

Bích Tỷ · 3/4/24

HieuCD đã viết:

Thêm điều kiện có dữ liệu

Mã:

Sub XYZ()
  Dim aRow&(1 To 5), a(), b(), res(), dic As Object, sh As Worksheet
  Dim sR&, n&, i&, k&, ik&, j&, Total#
 
  Set dic = CreateObject("scripting.dictionary")
  Set sh = ThisWorkbook.Sheets("data_report")
 
  For n = 1 To 5
    aRow(n) = Sheets("W" & n).Range("A" & Rows.Count).End(xlUp).Row - 6
    If aRow(n) > 0 Then sR = sR + aRow(n)
  Next n
  sR = sR + 1
  ReDim res(1 To sR, 1 To 10)
  For n = 1 To 5
    If aRow(n) > 0 Then
      a = Sheets("W" & n).Range("A7").Resize(aRow(n), 6).Value
      b = Sheets("W" & n).Range("AD7").Resize(aRow(n)).Value
      j = n + 4
      For i = 1 To aRow(n)
        If dic.exists(a(i, 5)) = False Then
          k = k + 1
          dic.Add a(i, 5), k
          res(k, 1) = k
          res(k, 2) = a(i, 5)
          res(k, 3) = a(i, 6)
          res(k, 4) = a(i, 1)
        End If
        ik = dic(a(i, 5))
        res(ik, j) = res(ik, j) + b(i, 1)
        res(sR, j) = res(sR, j) + b(i, 1)
        res(ik, 10) = res(ik, 10) + b(i, 1)
        Total = Total + b(i, 1)
      Next i
    End If
  Next n
  k = k + 1
  res(k, 1) = "TOTAL"
  res(k, 10) = Total
  For j = 5 To 9
    res(k, j) = res(sR, j)
  Next j
  With Sheets("data_report")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 7 Then .Range("A8:L" & i).Clear
    If k > 1 Then
      .Range("A8").Resize(k, 10) = res
      .Range("A8").Resize(k, 10).Borders.LineStyle = 1
    End If
  End With
End Sub

Cảm ơn anh nhiều ạ

Tổng hợp dữ liệu

Bích Tỷ

Thành viên chính thức

File đính kèm

HieuCD

Chuyên gia GPE

Bích Tỷ

Thành viên chính thức

LePhatHuy

Thành viên mới

File đính kèm

HieuCD

Chuyên gia GPE

Bích Tỷ

Thành viên chính thức

Bài viết mới nhất

Facebook

Group

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng