hiénlinh197
Thành viên tiêu biểu
- Tham gia
- 26/5/09
- Bài viết
- 491
- Được thích
- 113
Dùng Pivottable là được thôi bạnNhờ 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!
Viết code như nào bạn nhỉ?Dùng Pivottable là được thôi bạn
code như dưới đây, mỗi tội chạy hơi chậm nếu file nhiều dữ liệu.Viết code như nào bạn nhỉ?
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
Cảm ơn bạn rất nhiềucode 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
Phần này trong lúc làm mình lỡ tay xóa đi, bạn điền lại là xongCả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
Cảm ơn bạn, đúng rồi bạn àPhần này trong lúc làm mình lỡ tay xóa đi, bạn điền lại là xong
View attachment 206192
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 1Cả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á
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
Cảm ơn bạn đã giúp đỡ,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:
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é!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
Chúc bạn thành công.
Trong sheets("Dot1"), ô B4 đang bị trống bạn nhé!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ỉ?
Quá siêu tốcTrong sheets("Dot1"), ô B4 đang bị trống bạn nhé!
Điền lại như đề bài là được.
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2