Thống kê dữ liệu sang sheet khác (1 người xem)

[htruongtb911]

Hi mọi người,

Mình có file exel cần tổng hợp số liệu các sheet (lan 1, Lan 2,...) vào sheet tong hop một cách tự động đỡ phải copy từng mục khi có thêm sheet mới cập nhật vào. Mọi người ai biết chỉ hộ mình với.

Thanks.

 

[befaint]

Hi mọi người,

Mình có file exel cần tổng hợp số liệu các sheet (lan 1, Lan 2,...) vào sheet tong hop một cách tự động đỡ phải copy từng mục khi có thêm sheet mới cập nhật vào. Mọi người ai biết chỉ hộ mình với.

Thanks.

Bạn xem file đính kèm!

 

[phulien1902]

Hi mọi người,

Mình có file exel cần tổng hợp số liệu các sheet (lan 1, Lan 2,...) vào sheet tong hop một cách tự động đỡ phải copy từng mục khi có thêm sheet mới cập nhật vào. Mọi người ai biết chỉ hộ mình với.

Thanks.

+) Bạn chép Code dưới vào Sheets("tong hop"):

Private Sub Worksheet_Activate()
    Range("C2:F1000").ClearContents
    Call abc
    MsgBox " Cap nhat xong du lieu "
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Integer
    If Intersect(Target, Range("C:C")) Is Nothing Then Exit Sub
    For i = 2 To Range("c" & Rows.Count).End(xlUp).Row
        If Range("c" & i) = "" Then Range("b" & i) = "" Else _
           Range("B" & i) = Application.WorksheetFunction.CountA(Range("C2:C" & i))
    Next i
End Sub

+) Code Module:

Sub abc()
    Dim ArrIn(), ArrOut(1 To 65000, 1 To 5), i As Long, j As Long, k As Long, Ws As Worksheet
    For Each Ws In ThisWorkbook.Worksheets
        If Ws.Name <> "tong hop" Then
            ArrIn = Ws.Range(Ws.[B2], Ws.[B65000].End(xlUp)).Resize(, 5)
            For i = 2 To UBound(ArrIn, 1)
                k = k + 1
                For j = 2 To UBound(ArrIn, 2)
                    ArrOut(k, j) = ArrIn(i, j)
                Next j
            Next i
        End If
    Next
    With Sheets("tong hop")
        .[C2:F65000].ClearContents
        If k Then .[B2].Resize(k, 5).Value = ArrOut
    End With
    Columns("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

 

[vanthinh3101]

Bạn xem file đính kèm!

Bạn kiểm tra code giúp mình với.
Không hiểu sao code mình chạy được nhưng dòng dữ liệu cuối cùng luôn bị N/A
Thanks bạn.

 

[befaint]

Bạn kiểm tra code giúp mình với.
Không hiểu sao code mình chạy được nhưng dòng dữ liệu cuối cùng luôn bị N/A
Thanks bạn.

Sub TH()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim lr As Long, r As Long, ws As Worksheet, w0 As Worksheet
Set w0 = Sheets("tong hop")
w0.Range("B2").Resize(10000, 5).ClearContents
For Each ws In ThisWorkbook.Worksheets
    If ws.Name Like "Lan*" Then
        lr = ws.Range("C65000").End(xlUp).Row
        If lr >= 2 Then
            w0.Range("B2").Offset(r, 1).Resize(lr - 1, 4).Value _
            = ws.Range("C2:F" & lr).Value
            w0.Range("B2").Offset(r, 0).Resize(lr - 1, 1).Value = ws.Name
            r = r + lr - 1
        End If
    End If
Next ws
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[vanthinh3101]

Sub TH()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim lr As Long, r As Long, ws As Worksheet, w0 As Worksheet
Set w0 = Sheets("tong hop")
w0.Range("B2").Resize(10000, 5).ClearContents
For Each ws In ThisWorkbook.Worksheets
    If ws.Name Like "Lan*" Then
        lr = ws.Range("C65000").End(xlUp).Row
        If lr >= 2 Then
            w0.Range("B2").Offset(r, 1).Resize(lr - 1, 4).Value _
            = ws.Range("C2:F" & lr).Value
            w0.Range("B2").Offset(r, 0).Resize(lr - 1, 1).Value = ws.Name
            r = r + lr - 1
        End If
    End If
Next ws
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Cảm ơn bạn đã cho mình code đúng.
Bạn có thể giải thích giúp mình tại sao code của mình lại bị lỗi như vậy được không?

 

[befaint]

Bạn kiểm tra code giúp mình với.
Không hiểu sao code mình chạy được nhưng dòng dữ liệu cuối cùng luôn bị N/A
Thanks bạn.

(1) Sai (lrow1 - 1) ở chỗ set mảng (-1 thì bỏ mất dòng cuối có dữ liệu):

Set C = .Range("C2:C" & lrow1 - 1)
...
Set F=...

Vì các cột liên tiếp thì ghép luôn vào một vùng, và ta gán giá trị vùng đó vào 1 mảng luôn.
Khi đó:

Dim C As Range, D As Range, E As Range, F As Range
thay bằng:
Dim mang As Variant

Và

Set C = .Range("C2:C" & lrow1 - 1)
Set D = .Range("D2:D" & lrow1 - 1)
Set E = .Range("E2:E" & lrow1 - 1)
Set F = .Range("F2:F" & lrow1 - 1)
thay bằng:
mang = .Range("C2:F" & lrow1).Value

Và

.Range("C" & lrow2 + 1).Resize(lrow1 - 1, 1) = C.Value
.Range("D" & lrow2 + 1).Resize(lrow1 - 1, 1) = D.Value
.Range("E" & lrow2 + 1).Resize(lrow1 - 1, 1) = E.Value
.Range("F" & lrow2 + 1).Resize(lrow1 - 1, 1) = F.Value
thay bằng:
.Range("C" & lrow2 + 1).Resize(lrow1 - 1, 4) = mang

 

[vanthinh3101]

(1) Sai (lrow1 - 1) ở chỗ set mảng (-1 thì bỏ mất dòng cuối có dữ liệu):

Set C = .Range("C2:C" & lrow1 - 1)
...
Set F=...

Vì các cột liên tiếp thì ghép luôn vào một vùng, và ta gán giá trị vùng đó vào 1 mảng luôn.
Khi đó:

Dim C As Range, D As Range, E As Range, F As Range
thay bằng:
Dim mang As Variant

Và

Set C = .Range("C2:C" & lrow1 - 1)
Set D = .Range("D2:D" & lrow1 - 1)
Set E = .Range("E2:E" & lrow1 - 1)
Set F = .Range("F2:F" & lrow1 - 1)
thay bằng:
mang = .Range("C2:F" & lrow1).Value

Và

.Range("C" & lrow2 + 1).Resize(lrow1 - 1, 1) = C.Value
.Range("D" & lrow2 + 1).Resize(lrow1 - 1, 1) = D.Value
.Range("E" & lrow2 + 1).Resize(lrow1 - 1, 1) = E.Value
.Range("F" & lrow2 + 1).Resize(lrow1 - 1, 1) = F.Value
thay bằng:
.Range("C" & lrow2 + 1).Resize(lrow1 - 1, 4) = mang

Cảm ơn bạn nhiều lắm.
Mình đã hiểu ra rồi.