Tách trang tính Excel thành nhiều tệp dựa trên cột bằng VBA

Sub SplitIntoSheets()

With Application

.ScreenUpdating = False

.DisplayAlerts = False

End With

ThisWorkbook.Activate

Sheet1.Activate

'clearing filter if any

On Error Resume Next

Sheet1.ShowAllData

On Error GoTo 0

Dim lsrClm As Long

Dim lstRow As Long

'counting last used row

lstRow = Cells(Rows.Count, 1).End(xlUp).Row

Dim uniques As Range

Dim clm As String, clmNo As Long

On Error GoTo handler

clm = Application.InputBox("From which column you want create files" & vbCrLf & "E.g. A,B,C,AB,ZA etc.")

clmNo = Range(clm & "1").Column

Set uniques = Range(clm & "2:" & clm & lstRow)

'Calling Remove Duplicates to Get Unique Names

Set uniques = RemoveDuplicates(uniques)

Call CreateSheets(uniques, clmNo)

With Application

.ScreenUpdating = True

.DisplayAlerts = True

.AlertBeforeOverwriting = True

.Calculation = xlCalculationAutomatic

End With

Sheet1.Activate

MsgBox "Well Done!"

Exit Sub

Data.ShowAllData

handler:

With Application

.ScreenUpdating = True

.DisplayAlerts = True

.AlertBeforeOverwriting = True

.Calculation = xlCalculationAutomatic

End With

End Sub

Function RemoveDuplicates(uniques As Range) As Range

ThisWorkbook.Activate

Sheets.Add

On Error Resume Next

ActiveSheet.Name = "uniques"

Sheets("uniques").Activate

On Error GoTo 0

uniques.Copy

Cells(2, 1).Activate

ActiveCell.PasteSpecial xlPasteValues

Range("A1").Value = "uniques"

Dim lstRow As Long

lstRow = Cells(Rows.Count, 1).End(xlUp).Row

Range("A2:A" & lstRow).Select

ActiveSheet.Range(Selection.Address).RemoveDuplicates Columns:=1, Header:=xlNo

lstRow = Cells(Rows.Count, 1).End(xlUp).Row

Set RemoveDuplicates = Range("A2:A" & lstRow)

End Function

Sub CreateSheets(uniques As Range, clmNo As Long)

Dim lstClm As Long

Dim lstRow As Long



For Each unique In uniques

Sheet1.Activate

lstRow = Cells(Rows.Count, 1).End(xlUp).Row

lstClm = Cells(1, Columns.Count).End(xlToLeft).Column

Dim dataSet As Range

Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))

dataSet.AutoFilter field:=clmNo, Criteria1:=unique.Value

lstRow = Cells(Rows.Count, 1).End(xlUp).Row

lstClm = Cells(1, Columns.Count).End(xlToLeft).Column

Debug.Print lstRow; lstClm

Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))

dataSet.Copy

Sheets.Add

ActiveSheet.Name = unique.Value2

ActiveCell.PasteSpecial xlPasteAll

Next unique

End Sub