Option Explicit
Private Sub Worksheet_Activate()
Dim Rng As Range, TD As Range
Dim Er1 As Integer, Er2 As Integer, i As Integer
Dim Luu As Variant
Dim Sh As Worksheet '[B][COLOR=Blue]1>---> Mấy cái Dim này chắc khỏi cần nói nhỉ?[/COLOR][/B]
Application.ScreenUpdating = False [COLOR=Blue][B]'2>---> Thêm vào đầu code cho màn hình khỏi cà giật[/B][/COLOR]
With Sheet1
Er1 = .[C65536].End(xlUp).Row [B][COLOR=Blue] '3>---> Tại sheet1, Lấy cột C làm chuẩn, xác định xem dòng cuối cùng có dử liệu là dòng mấy[/COLOR][/B]
If Er1 <= 4 Then Er1 = 5 [COLOR=Blue][B]'4>---> Để làm cho Er1 luôn có giá trị nhỏ nhất là 5[/B][/COLOR]
.Range("A5:C" & Er1).ClearContents: .[C4].Cut: .[B4].Insert Shift:=xlToRight '[COLOR=Blue][B]5>---> Xóa hết vùng dử liệu từ cột A đến cột C, từ dòng 5 đến dòng Er1... tiếp theo đảo trật tự giữa C4 và B4[/B][/COLOR]
End With
For Each Sh In ThisWorkbook.Worksheets '[B][COLOR=Blue]6>---> Quét qua các sheet[/COLOR][/B]
Er2 = Sheet1.[A65536].End(xlUp).Row + 1 '[COLOR=Blue][B]7>---> Cùng lúc xem thử dòng cuối ở sheet 1 là dòng mấy[/B][/COLOR]
If Er2 <= 4 Then Er2 = 5 '[B][COLOR=Blue]8>---> Giống mục 4[/COLOR][/B]
If Sh.Name <> Sheet1.Name Then '[COLOR=Blue][B]9>---> Điều kiện này nói rằng: quét hết các sheet, trừ sheet1[/B][/COLOR]
With Sh
Set TD = .[A4].Resize(1, .[A4].End(xlToRight).Column) '[B][COLOR=Blue]10---> Xác định vùng tiêu đề ở mổi sheet[/COLOR][/B]
Luu = TD.Value: TD.ClearContents '[COLOR=Blue][B]11>---> Lưu lại vùng tiêu đề này vào 1 biến tạm sau đó xóa luôn tiêu đề[/B][/COLOR]
Set Rng = .[A5].CurrentRegion '[COLOR=Blue][B]12---> Xác định vùng dử liệu sau khi đã xóa tiêu đề[/B][/COLOR]
Rng.Copy Destination:=Sheet1.Cells(Er2, 1) '[B][COLOR=Blue]13---> Copy vùng dử liệu vừa xác định, paste vào dòng cuối cùng có dử liệu tại sheet 1, cột A[/COLOR][/B]
TD.Value = Luu '[COLOR=Blue][B]14>---> Copy và paste xong thì trả tiêu đề đã xóa về vị trí ban đầu[/B][/COLOR]
Sheet1.Cells(Er2, 3).Resize(Rng.Rows.Count, 1).Value = .Name '[COLOR=Blue][B]15>---> Mục 13 làm xong ta được 2 cột, giờ gán thêm cột thứ 3 chính là tên sheet mà ta vừa quét qua[/B][/COLOR]
End With
End If
Next Sh '[B][COLOR=Blue]16>----> Tiếp tục quét đến khi nào hết các sheet thì thôi[/COLOR][/B]
With Sheet1
.Range("C4:C" & .[C65536].End(xlUp).Row).Cut: .[B4].Insert Shift:=xlToRight '[COLOR=Blue][B]17>---> Đảo trật tự 2 cột B và C với nhau cho giống với yêu cầu của bạn[/B][/COLOR]
End With
Set Rng = Nothing: Set TD = Nothing '[B][COLOR=Blue]18>---> Xã xì... trét[/COLOR][/B]
Application.ScreenUpdating = True [COLOR=Blue]'[B]19>---> Ẹc... Ẹc.... Ở mục 2 ta đã làm cái gì đó, giờ trả mọi thứ về chổ củ[/B][/COLOR]
End Sub
