Nhờ các Thầy trên diễn đàn giúp tổng hợp các Sheet con theo dữ liệu Sheet_Temp

ntwl1080 · 24/5/18

Nhờ các Thầy trên diễn đàn giúp em Khi bấm Nút Tách Thôn từ Sheet_Temp ra thành nhiều Sheet (Thôn), dùng VBA để làm phần Tổng hợp ở cuối trang cho tất cả các sheet con tương tự như Sheet_Temp. Cảm ơn các Thầy.

giaiphap · 24/5/18

ntwl1080 đã viết:
Nhờ các Thầy trên diễn đàn giúp em Khi bấm Nút Tách Thôn từ Sheet_Temp ra thành nhiều Sheet (Thôn), dùng VBA để làm phần Tổng hợp ở cuối trang cho tất cả các sheet con tương tự như Sheet_Temp. Cảm ơn các Thầy.

Dùng thử code này xem sao? Bạn tự kiểm tra nhé.

Mã:

Public Sub GPE()
Dim Dic As Object, sArr(), Ws As Worksheet, i As Integer
    sArr() = Sheets("Sheet_Temp").Range("G8:G" & Sheets("Sheet_Temp").Range("G65000").End(xlUp).Row).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(sArr, 1)
        If Not Dic.exists(sArr(i, 1)) Then
            Dic.Add sArr(i, 1), ""
            Sheets("Sheet_Temp").Range("K3").Value = sArr(i, 1)
            Set Ws = Worksheets.Add(, Sheets("Sheet_Temp"))
            Ws.Name = sArr(i, 1)
            Sheets("Sheet_Temp").Range("A7:N1684").AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=Sheets("Sheet_Temp").Range("K2:K3"), CopyToRange:=Ws.Range("A6:N6"), Unique:=False
        End If
    Next i
    Set Dic = Nothing
End Sub

ntwl1080 · 24/5/18

Dạ, em cảm ơn.
Code trên chỉ copy mỗi tiêu đề cột thôi ạ.
nút Tách thôn em làm được phần nội dụng, còn phần tổng hợp cuối mỗi sheet (Tổng số trẻ nam được cân:Tổng số trẻ nam SDD theo CN:Tổng số trẻ nam SDD theo CC:....)
e muốn làm bằng vba để tự tính cho tất cả các sheet (thôn) sau khi tách ạ. có ai biết giúp e. em cảm ơn.

giaiphap · 25/5/18

ntwl1080 đã viết:
Dạ, em cảm ơn.
Code trên chỉ copy mỗi tiêu đề cột thôi ạ.
nút Tách thôn em làm được phần nội dụng, còn phần tổng hợp cuối mỗi sheet (Tổng số trẻ nam được cân:Tổng số trẻ nam SDD theo CN:Tổng số trẻ nam SDD theo CC:....)
e muốn làm bằng vba để tự tính cho tất cả các sheet (thôn) sau khi tách ạ. có ai biết giúp e. em cảm ơn.

Thử sửa lại thế này xem sao?

Mã:

Public Sub GPE()
Dim Dic As Object, sArr(), Ws As Worksheet, i As Integer, Rng As Range
    sArr() = Sheets("Sheet_Temp").Range("G8:G" & Sheets("Sheet_Temp").Range("G65000").End(xlUp).Row).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet_Temp")
        .Range("P2").Value = .Range("G7").Value
        For i = 1 To UBound(sArr, 1)
            If Not Dic.exists(sArr(i, 1)) Then
                Dic.Add sArr(i, 1), ""
                .Range("P3").Value = sArr(i, 1)
                Set Ws = Worksheets.Add(, Sheets("Sheet_Temp"))
                Ws.Name = sArr(i, 1)
                .Range("A7:N1684").AdvancedFilter Action:=xlFilterCopy, _
                CriteriaRange:=.Range("P2:P3"), CopyToRange:=Ws.Range("A6:N6"), Unique:=False
                Set Rng = Ws.Range("A65000").End(xlUp)
                With Rng.Offset(3)
                    .Value = "T" & ChrW(7893) & "ng s" & ChrW(7889) & " tr" & ChrW(7867) & " nam ðý" & ChrW(7907) & "c cân:"
                    .Offset(, 3).FormulaR1C1 = "=COUNTIFS(R7C4:R" & (.Row - 3) & "C4,1,R7C8:R" & (.Row - 3) & "C8,""<>"""""")"
                    .Offset(1).Value = "T" & ChrW(7893) & "ng s" & ChrW(7889) & " tr" & ChrW(7867) & " nam SDD theo CN:"
                    .Offset(1, 3).FormulaR1C1 = "=COUNTIFS(R7C4:R" & (.Row - 3) & "C4,1,R7C13:R" & (.Row - 3) & "C13,""SDD"")"
                    .Offset(2).Value = "T" & ChrW(7893) & "ng s" & ChrW(7889) & " tr" & ChrW(7867) & " nam SDD theo CC:"
                    .Offset(2, 3).FormulaR1C1 = "=COUNTIFS(R7C4:R" & (.Row - 3) & "C4,1,R7C14:R" & (.Row - 3) & "C14,""SDD"")"
                    
                    .Offset(, 7).Value = "T" & ChrW(7893) & "ng s" & ChrW(7889) & " tr" & ChrW(7867) & " n" & ChrW(7919) & " ðý" & ChrW(7907) & "c cân:"
                    .Offset(, 9).FormulaR1C1 = "=COUNTIFS(R7C4:R" & (.Row - 3) & "C4,2,R7C8:R" & (.Row - 3) & "C8,""<>"""""")"
                    .Offset(1, 7).Value = "T" & ChrW(7893) & "ng s" & ChrW(7889) & " tr" & ChrW(7867) & " n" & ChrW(7919) & " SDD theo CN:"
                    .Offset(1, 9).FormulaR1C1 = "=COUNTIFS(R7C4:R" & (.Row - 3) & "C4,2,R7C13:R" & (.Row - 3) & "C13,""SDD"")"
                    .Offset(2, 7).Value = "T" & ChrW(7893) & "ng s" & ChrW(7889) & " tr" & ChrW(7867) & " n" & ChrW(7919) & " SDD theo CC:"
                    .Offset(2, 9).FormulaR1C1 = "=COUNTIFS(R7C4:R" & (.Row - 3) & "C4,2,R7C14:R" & (.Row - 3) & "C14,""SDD"")"
                    .Resize(3, 10).Value = .Resize(3, 10).Value
                End With
            End If
        Next i
        .Range("P2:P3").ClearContents
    End With
    Set Dic = Nothing
End Sub

ntwl1080 · 25/5/18

Dạ, Cảm ơn thầy. đúng theo ý em rồi.

ntwl1080 · 28/5/18

Thầy giúp em phần Tổng hợp. Cảm ơn Thầy

giaiphap · 31/5/18

ntwl1080 đã viết:
Thầy giúp em phần Tổng hợp. Cảm ơn Thầy

Bạn thử code này xem sao? Nhớ kiểm tra lại kết quả nhé.

Mã:

Sub GPE_TongHop()
Dim Dic As Object, Tmp As String
Dim i As Long, n As Long, k As Long
Dim Arr, dArr
Arr = Sheet_Temp.Range("B8:N" & Sheet_Temp.[A65000].End(3).Row).Value
ReDim dArr(1 To UBound(Arr, 1), 1 To 17)
Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
        For i = 1 To UBound(Arr, 1)
            Tmp = Arr(i, 6)
            If Not .Exists(Tmp) Then
                k = k + 1
                .Add Tmp, k
                dArr(k, 1) = k: dArr(k, 2) = Tmp: dArr(k, 5) = 1
                If Arr(i, 4) = "" Then
                    dArr(k, 3) = 1
                    If Arr(i, 7) <> "" Then dArr(k, 6) = 1
                ElseIf UCase(Arr(i, 4)) = "X" Then
                    dArr(k, 4) = 1
                    If Arr(i, 7) <> "" Then dArr(k, 7) = 1
                End If
                If Arr(i, 7) <> "" Then dArr(k, 8) = 1
            Else
                n = .Item(Tmp)
                dArr(n, 5) = dArr(n, 5) + 1
                If Arr(i, 4) = "" Then
                    dArr(n, 3) = dArr(n, 3) + 1
                    If Arr(i, 7) <> "" Then dArr(n, 6) = dArr(n, 6) + 1
                ElseIf UCase(Arr(i, 4)) = "X" Then
                    dArr(n, 4) = dArr(n, 4) + 1
                    If Arr(i, 7) <> "" Then dArr(n, 7) = dArr(n, 7) + 1
                End If
                If Arr(i, 7) <> "" Then dArr(n, 8) = dArr(n, 8) + 1
            End If
        Next i
    End With
    Sheets("TongHop").Range("A8:N" & Sheets("TongHop").Range("A65000").End(3).Row).ClearContents
    Sheets("TongHop").Range("A8").Resize(k, 17) = dArr
    MsgBox "Da thuc hien xong", vbExclamation, "Thông báo!"
End Sub

ntwl1080 · 31/5/18

giaiphap đã viết:

Bạn thử code này xem sao? Nhớ kiểm tra lại kết quả nhé.

Mã:

Sub GPE_TongHop()
Dim Dic As Object, Tmp As String
Dim i As Long, n As Long, k As Long
Dim Arr, dArr
Arr = Sheet_Temp.Range("B8:N" & Sheet_Temp.[A65000].End(3).Row).Value
ReDim dArr(1 To UBound(Arr, 1), 1 To 17)
Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
        For i = 1 To UBound(Arr, 1)
            Tmp = Arr(i, 6)
            If Not .Exists(Tmp) Then
                k = k + 1
                .Add Tmp, k
                dArr(k, 1) = k: dArr(k, 2) = Tmp: dArr(k, 5) = 1
                If Arr(i, 4) = "" Then
                    dArr(k, 3) = 1
                    If Arr(i, 7) <> "" Then dArr(k, 6) = 1
                ElseIf UCase(Arr(i, 4)) = "X" Then
                    dArr(k, 4) = 1
                    If Arr(i, 7) <> "" Then dArr(k, 7) = 1
                End If
                If Arr(i, 7) <> "" Then dArr(k, 8) = 1
            Else
                n = .Item(Tmp)
                dArr(n, 5) = dArr(n, 5) + 1
                If Arr(i, 4) = "" Then
                    dArr(n, 3) = dArr(n, 3) + 1
                    If Arr(i, 7) <> "" Then dArr(n, 6) = dArr(n, 6) + 1
                ElseIf UCase(Arr(i, 4)) = "X" Then
                    dArr(n, 4) = dArr(n, 4) + 1
                    If Arr(i, 7) <> "" Then dArr(n, 7) = dArr(n, 7) + 1
                End If
                If Arr(i, 7) <> "" Then dArr(n, 8) = dArr(n, 8) + 1
            End If
        Next i
    End With
    Sheets("TongHop").Range("A8:N" & Sheets("TongHop").Range("A65000").End(3).Row).ClearContents
    Sheets("TongHop").Range("A8").Resize(k, 17) = dArr
    MsgBox "Da thuc hien xong", vbExclamation, "Thông báo!"
End Sub

Dạ, cảm ơn Thầy, Số liệu chưa đầy đủ theo yêu cầu, để em tự nghiên cứu phát triển. vướng em lại nhờ Thầy giúp

Ba Tê · 31/5/18

ntwl1080 đã viết:
Dạ, cảm ơn Thầy, Số liệu chưa đầy đủ theo yêu cầu, để em tự nghiên cứu phát triển. vướng em lại nhờ Thầy giúp

Các công thức mẫu từ cột C đến cột I sao chưa đày đủ? Kết quả từ công thức có chính xác không? (Để mọi người xem công thức mới hiểu ý bạn mà viết code)
Cột J đến cột Q thì tính thế nào?

ntwl1080 · 31/5/18

Dùng Record Macro được kết quả như trong file đính kèm, muốn sử dụng VBA để tổng hợp dữ liệu của 1 xã bất kỳ (Số thôn có thể khác trong file đính kèm). Nhờ Thầy giaiphap và Thầy Ba Tê giúp em với. Em cảm ơn các Thầy

giaiphap · 31/5/18

ntwl1080 đã viết:
Dùng Record Macro được kết quả như trong file đính kèm, muốn sử dụng VBA để tổng hợp dữ liệu của 1 xã bất kỳ (Số thôn có thể khác trong file đính kèm). Nhờ Thầy giaiphap và Thầy Ba Tê giúp em với. Em cảm ơn các Thầy

Tôi để lại 2 chổ SO TRE SDD CN và SO TRE SDD CC để bạn tự thực hiện nhé.

Ba Tê · 31/5/18

ntwl1080 đã viết:
Dùng Record Macro được kết quả như trong file đính kèm, muốn sử dụng VBA để tổng hợp dữ liệu của 1 xã bất kỳ (Số thôn có thể khác trong file đính kèm). Nhờ Thầy giaiphap và Thầy Ba Tê giúp em với. Em cảm ơn các Thầy

Làm "y chang" theo công thức của bạn, nếu không chính xác thì bạn tự sửa.

ntwl1080 · 31/5/18

Dạ, cảm ơn 2 Thầy đã giúp.

Nhờ các Thầy trên diễn đàn giúp tổng hợp các Sheet con theo dữ liệu Sheet_Temp

ntwl1080

Thành viên mới

File đính kèm

giaiphap

==(^o^)==

ntwl1080

Thành viên mới

giaiphap

==(^o^)==

ntwl1080

Thành viên mới

ntwl1080

Thành viên mới

File đính kèm

giaiphap

==(^o^)==

ntwl1080

Thành viên mới

Ba Tê

Cạo Rồi Khỏi Gội

ntwl1080

Thành viên mới

File đính kèm

giaiphap

==(^o^)==

File đính kèm

Ba Tê

Cạo Rồi Khỏi Gội

File đính kèm

ntwl1080

Thành viên mới

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

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

Đếm ngược thời gian