Option Explicit
'Tac gia: Nguyen Duy Tuan - http://bluesofts.net - Zalo: 0904210337
'Khoa hoc lap trinh VBA cua tac gia:
'https://bluesofts.net/daotaothuchanh/lap-trinh-vba-co-ban-tao-macro.html
Sub CopySheetTo()
Dim wb As Workbook 'File Dich
Dim sh As Worksheet, sFileName As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error GoTo lbFinally
For Each sh In ActiveWindow.SelectedSheets 'Quet vao tung sheet dang chon
sFileName = sh.Range("D2") & ".xlsx"
If Not GetWb(sFileName, wb) Then 'Kiem tra ten File co dang duoc mo khong?
Set wb = CreateNewWb(sFileName)
End If
sh.Copy wb.Sheets(1)
Next sh
lbFinally:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
If Err <> 0 Then
MsgBox Err.Description, vbCritical
End If
End Sub
'Neu GetWb=True, thi Wb tro vao workbook co sWbName
'Neu GetWb=False, chua tung co file voi ten sWbName
Function GetWb(sWbName As String, wb As Workbook) As Boolean
Dim I As Long
sWbName = LCase(sWbName)
For I = 1 To Workbooks.Count
If LCase(Workbooks(I).Name) = sWbName Then
GetWb = True
Set wb = Workbooks(I)
Exit Function
End If
Next I
End Function
Function CreateNewWb(sWbName As String) As Workbook
Dim oldWb As Workbook
Set oldWb = ActiveWorkbook
Set CreateNewWb = Workbooks.Add 'Tao moi workbook
CreateNewWb.SaveAs sWbName
oldWb.Activate
End Function
|