VBA Tổng hợp nhiều sheet có số liệu giống nhau vào các sheet mới

Liên hệ QC
H

hiénlinh197

Thành viên tiêu biểu
Tham gia
26/5/09
Bài viết
491
Được thích
113
Nhờ các bạn viết code VBA tổng hợp nhiều sheet có số liệu giống nhau vào các sheet mới như file đính kèm
Cảm ơn các bạn!
 

File đính kèm

  • Theo dõi đề xê (Hỏi).xlsx
    17.5 KB · Đọc: 24
Sắp xếp theo thời gian sắp xếp theo bầu chọn
hiénlinh197 đã viết:
Viết code như nào bạn nhỉ?
Nhấp chuột vào đây để mở rộng...
code như dưới đây, mỗi tội chạy hơi chậm nếu file nhiều dữ liệu.
chắc có code khác nhanh hơn nhưng tôi chưa biết làm
Mã: 
Sub test()
Dim sh As Worksheet, Arrsheetname As Range, Rng As Range
Dim Lr As Long, Lr_1 As Long, Lr_2 As Long, i As Long

For Each sh In Worksheets
    Lr = Sheets("Tong_hop").Cells(Rows.Count, "B").End(xlUp).Row + 1
    If sh.Name <> "Tong_hop" And sh.Name <> "Blank" Then
        sh.Range("A3").CurrentRegion.Copy Destination:=Sheets("Tong_hop").Range("A" & Lr)
    End If
Next sh
With Sheets("Tong_hop")
    Lr_2 = .Cells(Rows.Count, "B").End(xlUp).Row
    .Range("B2:B" & Lr_2).Copy Destination:=.Range("G2:G" & Lr_2)
    .Range("G2:G" & Lr_2).RemoveDuplicates Columns:=1, Header:=xlYes
End With
Lr_1 = Sheets("Tong_hop").Cells(Rows.Count, "G").End(xlUp).Row
Set Arrsheetname = Sheets("Tong_hop").Range("G4:G" & Lr_1)
For Each Rng In Arrsheetname
    If Rng.Value <> "" Then
        Sheets("Tong_hop").Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = Rng.Value
        With ActiveSheet
            For i = Lr_2 To 4 Step -1
                If .Cells(i, "B").Value <> .Name Then .Cells(i, "B").EntireRow.Delete
                    .Columns(7).Delete
            Next i
        End With
    End If
Next Rng
End Sub
 

File đính kèm

  • Theo dõi đề xê (Hỏi).xlsb
    35.3 KB · Đọc: 22
Upvote 0
nguyenthuy13388 đã viết:
code như dưới đây, mỗi tội chạy hơi chậm nếu file nhiều dữ liệu.
chắc có code khác nhanh hơn nhưng tôi chưa biết làm
Mã: 
Sub test()
Dim sh As Worksheet, Arrsheetname As Range, Rng As Range
Dim Lr As Long, Lr_1 As Long, Lr_2 As Long, i As Long

For Each sh In Worksheets
    Lr = Sheets("Tong_hop").Cells(Rows.Count, "B").End(xlUp).Row + 1
    If sh.Name <> "Tong_hop" And sh.Name <> "Blank" Then
        sh.Range("A3").CurrentRegion.Copy Destination:=Sheets("Tong_hop").Range("A" & Lr)
    End If
Next sh
With Sheets("Tong_hop")
    Lr_2 = .Cells(Rows.Count, "B").End(xlUp).Row
    .Range("B2:B" & Lr_2).Copy Destination:=.Range("G2:G" & Lr_2)
    .Range("G2:G" & Lr_2).RemoveDuplicates Columns:=1, Header:=xlYes
End With
Lr_1 = Sheets("Tong_hop").Cells(Rows.Count, "G").End(xlUp).Row
Set Arrsheetname = Sheets("Tong_hop").Range("G4:G" & Lr_1)
For Each Rng In Arrsheetname
    If Rng.Value <> "" Then
        Sheets("Tong_hop").Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = Rng.Value
        With ActiveSheet
            For i = Lr_2 To 4 Step -1
                If .Cells(i, "B").Value <> .Name Then .Cells(i, "B").EntireRow.Delete
                    .Columns(7).Delete
            Next i
        End With
    End If
Next Rng
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn rất nhiều
Bạn đã viết code đúng theo ý tưởng của mình
đúng là code chạy hơi chậm 1 chút, nhưng dù sao cũng gấp vạn lần phải đi làm thủ công bạn à.
(Bạn ơi mình đã kiểm tra code vẫn chạy sai dữ liệu của số liệu sheet "D10" trong sheet"Đợt1" có 2 lần D10 nhưng kết quả chỉ có 1 lần D10
Bạn sửa giúp mình với nhé
Cảm ơn bạn
 
Upvote 0
hiénlinh197 đã viết:
Cảm ơn bạn rất nhiều
Bạn đã viết code đúng theo ý tưởng của mình
đúng là code chạy hơi chậm 1 chút, nhưng dù sao cũng gấp vạn lần phải đi làm thủ công bạn à.
(Bạn ơi mình đã kiểm tra code vẫn chạy sai dữ liệu của số liệu sheet "D10" trong sheet"Đợt1" có 2 lần D10 nhưng kết quả chỉ có 1 lần D10
Bạn sửa giúp mình với nhé
Cảm ơn bạn
Nhấp chuột vào đây để mở rộng...
Phần này trong lúc làm mình lỡ tay xóa đi, bạn điền lại là xong
1540261573501.png
 
Upvote 0
hiénlinh197 đã viết:
Cảm ơn bạn, đúng rồi bạn à
Bạn nghiên cứu giúp mình xem có cách nào cải thiện tốc độ nhanh lên được không bạn nhá
Nhấp chuột vào đây để mở rộng...
Bạn sửa lại tên Sheets các đợt cần tổng hợp thành không có dấu, ví dụ: Đợt 1 --> Dot 1
Chạy thử code sau:
PHP: 
Sub Tonghop()
    Dim Dic1 As Object, Dic2 As Object, Ws As Worksheet, Tmp1, Tmp2
    Dim Tem As String, Header As Range, I As Long, J As Long, K As Long
    Dim sArr(), dArr()
    
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Set Dic2 = CreateObject("Scripting.Dictionary")
    Set Header = Sheet1.Range("B3:D3")
    
    Application.ScreenUpdating = False
    For Each Ws In ThisWorkbook.Sheets
        If Ws.Name Like "Dot*" Then
            sArr() = Ws.Range("B4", Ws.Range("B4").End(xlDown)).Resize(, 3).Value
            For I = 1 To UBound(sArr, 1)
                If Not Dic1.exists(sArr(I, 1)) Then
                    Dic1.Add sArr(I, 1), ""
                End If
                
                Tem = sArr(I, 1) & "|" & sArr(I, 2)
                If Not Dic2.exists(Tem) Then
                    Dic2.Add Tem, sArr(I, 3)
                Else
                    Dic2(Tem) = Dic2(Tem) + sArr(I, 3)
                End If
            Next I
        End If
    Next Ws
    
    Tmp1 = Dic1.keys
    Tmp2 = Dic2.keys
    
    For I = LBound(Tmp1) To UBound(Tmp1)
        ReDim dArr(1 To Dic2.Count, 1 To 3)
        K = 0
        For J = LBound(Tmp2) To UBound(Tmp2)
            If Tmp1(I) = Split(Tmp2(J), "|")(0) Then
                K = K + 1: dArr(K, 1) = Tmp1(I)
                dArr(K, 2) = Split(Tmp2(J), "|")(1)
                dArr(K, 3) = Dic2(Tmp2(J))
            End If
        Next J
        Set Ws = Sheets.Add(after:=Sheets(Sheets.Count))
        Ws.Name = Tmp1(I)
        Header.Copy Ws.Range("B3")
        Ws.Range("B4").Resize(K, 3) = dArr
        Ws.Range("B3").CurrentRegion.Borders.LineStyle = 1
        Erase dArr
    Next I
    
    Set Dic1 = Nothing: Set Dic2 = Nothing: Set Header = Nothing
    Application.ScreenUpdating = True
    
    MsgBox "Done", vbInformation, "GPE"
End Sub
Code này sẽ tính tổng số lượng trong trường hợp cùng đường kính và chiều dài nhé!
Chúc bạn thành công.
 
Upvote 0
vanthinh3101 đã viết:
Bạn sửa lại tên Sheets các đợt cần tổng hợp thành không có dấu, ví dụ: Đợt 1 --> Dot 1
Chạy thử code sau:
PHP: 
Sub Tonghop()
    Dim Dic1 As Object, Dic2 As Object, Ws As Worksheet, Tmp1, Tmp2
    Dim Tem As String, Header As Range, I As Long, J As Long, K As Long
    Dim sArr(), dArr()
   
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Set Dic2 = CreateObject("Scripting.Dictionary")
    Set Header = Sheet1.Range("B3:D3")
   
    Application.ScreenUpdating = False
    For Each Ws In ThisWorkbook.Sheets
        If Ws.Name Like "Dot*" Then
            sArr() = Ws.Range("B4", Ws.Range("B4").End(xlDown)).Resize(, 3).Value
            For I = 1 To UBound(sArr, 1)
                If Not Dic1.exists(sArr(I, 1)) Then
                    Dic1.Add sArr(I, 1), ""
                End If
               
                Tem = sArr(I, 1) & "|" & sArr(I, 2)
                If Not Dic2.exists(Tem) Then
                    Dic2.Add Tem, sArr(I, 3)
                Else
                    Dic2(Tem) = Dic2(Tem) + sArr(I, 3)
                End If
            Next I
        End If
    Next Ws
   
    Tmp1 = Dic1.keys
    Tmp2 = Dic2.keys
   
    For I = LBound(Tmp1) To UBound(Tmp1)
        ReDim dArr(1 To Dic2.Count, 1 To 3)
        K = 0
        For J = LBound(Tmp2) To UBound(Tmp2)
            If Tmp1(I) = Split(Tmp2(J), "|")(0) Then
                K = K + 1: dArr(K, 1) = Tmp1(I)
                dArr(K, 2) = Split(Tmp2(J), "|")(1)
                dArr(K, 3) = Dic2(Tmp2(J))
            End If
        Next J
        Set Ws = Sheets.Add(after:=Sheets(Sheets.Count))
        Ws.Name = Tmp1(I)
        Header.Copy Ws.Range("B3")
        Ws.Range("B4").Resize(K, 3) = dArr
        Ws.Range("B3").CurrentRegion.Borders.LineStyle = 1
        Erase dArr
    Next I
   
    Set Dic1 = Nothing: Set Dic2 = Nothing: Set Header = Nothing
    Application.ScreenUpdating = True
   
    MsgBox "Done", vbInformation, "GPE"
End Sub
Code này sẽ tính tổng số lượng trong trường hợp cùng đường kính và chiều dài nhé!
Chúc bạn thành công.
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn đã giúp đỡ,
Mình chạy không được bạn ơi
Không biết do lỗi gì bạn nhỉ?
 

File đính kèm

  • Theo dõi đề xê (Hỏi)2.xlsb
    27.7 KB · Đọc: 16
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

K
Nhờ mọi người hỗ trợ giúp mình về tìm kiếm trong VBA. Mình sẽ gửi chút chi phí cafe cám ơn nhiều ạ
    • Cười
Trả lời
10
Đọc
125
kentshjnks
K
S
Nhờ giúp đỡ code in toàn bộ danh sách có điều kiện
Trả lời
12
Đọc
320
S.Ha
S
phammaihuong90
Hàm tìm ngày gần nhất đạt được số lượng mục tiêu
Trả lời
8
Đọc
197
DeTong
D
Emyeuexcel
  • Question
VBA lưu file, in, và mở lại file gốc ban đầu
2
Trả lời
21
Đọc
375
Emyeuexcel
Emyeuexcel
hongquan93vn
Giữ được Hide dòng khi dùng "clear" trong phần học
Trả lời
3
Đọc
63
Hoàng Tuấn 868
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom