[Giúp] VBA Coppy Sheet sang một file mới và save File mới tại đường dẫn của File nguồn

robinhsoon · 24/6/17

Xin chào Cả Nhà GPEX!

Hiện tại em có một file nguồn Excel gồm 4 sheet A,B,C,D...
Em muốn xin đoạn code VBA để Coppy sheet A + Sheet B + Sheet D sang một file mới và Save file cạnh bên File nguồn ạ..!

Mong cả nhà giúp đỡ ạ! Em xin cảm ơn ạ!

phulien1902 · 24/6/17

robinhsoon đã viết:
Xin chào Cả Nhà GPEX!

Hiện tại em có một file nguồn Excel gồm 4 sheet A,B,C,D...
Em muốn xin đoạn code VBA để Coppy sheet A + Sheet B + Sheet D sang một file mới và Save file cạnh bên File nguồn ạ..!

Mong cả nhà giúp đỡ ạ! Em xin cảm ơn ạ!

Bạn thử với:

PHP:

Sub abc()
    Dim FName As String
    FName = InputBox("Vui long nhap ten File moi :", "Thong bao")
    If FName <> "" Then
        ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & FName
    End If
End Sub

vanthinh3101 · 24/6/17

robinhsoon đã viết:
Xin chào Cả Nhà GPEX!

Hiện tại em có một file nguồn Excel gồm 4 sheet A,B,C,D...
Em muốn xin đoạn code VBA để Coppy sheet A + Sheet B + Sheet D sang một file mới và Save file cạnh bên File nguồn ạ..!

Mong cả nhà giúp đỡ ạ! Em xin cảm ơn ạ!

Bạn thử sử dụng code này, mỗi sheet sẽ tạo thành 1 file mới

Mã:

Sub Add_New_Workbook()
    Application.DisplayAlerts = False
    Dim Wk As Workbook, Wk1 As Workbook
    Dim WkName As String, Wk1Name As String
    Dim ChuaSheets, TimSh, XoaSheets
    ChuaSheets = Array("")
    Set Wk = ThisWorkbook
    WkName = Wk.Name
  
    For Each TimSh In Worksheets
        XoaSheets = Filter(ChuaSheets, TimSh.Name, 1)
        If UBound(XoaSheets) <> 0 Then
            Set Wk1 = Workbooks.Add
            Windows(WkName).Activate
            TimSh.Select
            Wk1Name = Wk.Path & "\" & TimSh.Name & ".xlsx"
            TimSh.Copy after:=Wk1.Sheets(1)
            ChDir Wk.Path
            Wk1.SaveAs Wk1Name, xlOpenXMLWorkbook
            Wk1.Close
        End If
    Next
    Application.DisplayAlerts = True

End Sub

Trường hợp bạn không muốn tạo file từ sheet nào thì bạn chỉ cần điền tên sheet đó vào trong dấu "" của ChuaSheets = Array("")
Ví dụ: bạn có 6 sheet A, B, C, D, E, F, bạn chỉ muốn tạo file từ A, B, C, D --> ChuaSheets=Array("E", "F","")

robinhsoon · 26/6/17

phulien1902 đã viết:
Bạn thử với:

PHP:

Sub abc() Dim FName As String FName = InputBox("Vui long nhap ten File moi :", "Thong bao") If FName <> "" Then ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & FName End If End Sub

Cảm ơn Thầy đã giúp đỡ ạ,
code của Thầy là Save as File ạ...
Ý em là chỉ Save as các Sheet A, B, D thành 01 file mới gồm 3 sheet đó thôi ạ...
Mong Thầy giúp đỡ

robinhsoon · 26/6/17

vanthinh3101 đã viết:
Bạn thử sử dụng code này, mỗi sheet sẽ tạo thành 1 file mới

Mã:

Sub Add_New_Workbook() Application.DisplayAlerts = False Dim Wk As Workbook, Wk1 As Workbook Dim WkName As String, Wk1Name As String Dim ChuaSheets, TimSh, XoaSheets ChuaSheets = Array("") Set Wk = ThisWorkbook WkName = Wk.Name For Each TimSh In Worksheets XoaSheets = Filter(ChuaSheets, TimSh.Name, 1) If UBound(XoaSheets) <> 0 Then Set Wk1 = Workbooks.Add Windows(WkName).Activate TimSh.Select Wk1Name = Wk.Path & "\" & TimSh.Name & ".xlsx" TimSh.Copy after:=Wk1.Sheets(1) ChDir Wk.Path Wk1.SaveAs Wk1Name, xlOpenXMLWorkbook Wk1.Close End If Next Application.DisplayAlerts = True End Sub

Trường hợp bạn không muốn tạo file từ sheet nào thì bạn chỉ cần điền tên sheet đó vào trong dấu "" của ChuaSheets = Array("")
Ví dụ: bạn có 6 sheet A, B, C, D, E, F, bạn chỉ muốn tạo file từ A, B, C, D --> ChuaSheets=Array("E", "F","")

Chào Thầy! Cảm ơn Thầy đã giúp em ạ...
Code của Thầy là coppy ra từng sheet ạ... Ý của em là trong File có 4 sheet A,B,C,D thì mình chỉ copy 3 sheet A,B,D vào một File chung thôi ạ.. Chứ không phải tách từng file...
Mong Thầy giúp đỡ ạ.!

phulien1902 · 26/6/17

Bạn thử:

PHP:

Sub abc2()
    Dim i As Byte, Path As String, FName As String
    On Error Resume Next
    Sheets(Array("A", "B", "D")).Copy
    Path = ThisWorkbook.Path
    With ActiveWorkbook
         .SaveAs ThisWorkbook.Path & "\" & FName, 50
        For i = 1 To .Sheets.Count
            .Sheets(i).Activate
        Next i
        .Close True
    End With
End Sub

vanthinh3101 · 26/6/17

robinhsoon đã viết:
Chào Thầy! Cảm ơn Thầy đã giúp em ạ...
Code của Thầy là coppy ra từng sheet ạ... Ý của em là trong File có 4 sheet A,B,C,D thì mình chỉ copy 3 sheet A,B,D vào một File chung thôi ạ.. Chứ không phải tách từng file...
Mong Thầy giúp đỡ ạ.!

Mình sửa lại 1 chút

Mã:

Sub Add_New_Workbook()
    Application.DisplayAlerts = False
    Dim Wk As Workbook, Wk1 As Workbook
    Dim WkName As String, Wk1Name As String
    Dim ChuaSheets, TimSh, XoaSheets
    ChuaSheets = Array("C", "")
    Set Wk = ThisWorkbook
    WkName = Wk.Name
    Set Wk1 = Workbooks.Add
    Wk1Name = Wk.Path & "\" & "File moi.xlsx"
    
    
    For Each TimSh In Wk.Worksheets
        Windows(WkName).Activate
        XoaSheets = Filter(ChuaSheets, TimSh.Name, 1)
        If UBound(XoaSheets) <> 0 Then
            TimSh.Select
            TimSh.Copy after:=Wk1.Sheets(Wk1.Sheets.Count)
        End If
    Next
    ChDir Wk.Path
    Wk1.SaveAs Wk1Name, xlOpenXMLWorkbook
    Wk1.Close
    Application.DisplayAlerts = True

End Sub

robinhsoon · 26/6/17

vanthinh3101 đã viết:

Mình sửa lại 1 chút

Mã:

Sub Add_New_Workbook()
    Application.DisplayAlerts = False
    Dim Wk As Workbook, Wk1 As Workbook
    Dim WkName As String, Wk1Name As String
    Dim ChuaSheets, TimSh, XoaSheets
    ChuaSheets = Array("C", "")
    Set Wk = ThisWorkbook
    WkName = Wk.Name
    Set Wk1 = Workbooks.Add
    Wk1Name = Wk.Path & "\" & "File moi.xlsx"
   
   
    For Each TimSh In Wk.Worksheets
        Windows(WkName).Activate
        XoaSheets = Filter(ChuaSheets, TimSh.Name, 1)
        If UBound(XoaSheets) <> 0 Then
            TimSh.Select
            TimSh.Copy after:=Wk1.Sheets(Wk1.Sheets.Count)
        End If
    Next
    ChDir Wk.Path
    Wk1.SaveAs Wk1Name, xlOpenXMLWorkbook
    Wk1.Close
    Application.DisplayAlerts = True

End Sub

Cảm ơn Thầy đúng ý em rồi ạ..!
Nhưng khi xuất ra FIle mới lại có sheet 1, Sheet 2, Sheet 3 nữa?.. Mình tự động bỏ những sheet đó được không Thầy?

phuyen89 · 26/6/17

robinhsoon đã viết:
Cảm ơn Thầy đúng ý em rồi ạ..!
Nhưng khi xuất ra FIle mới lại có sheet 1, Sheet 2, Sheet 3 nữa?.. Mình tự động bỏ những sheet đó được không Thầy?

Vẫn bỏ được đó bạn.

PHP:

Sub Add_New_Workbook()
    Application.DisplayAlerts = False
    Dim Wk As Workbook, Wk1 As Workbook
    Dim WkName As String, Wk1Name As String
    Dim ChuaSheets, TimSh, XoaSheets
    ChuaSheets = Array("C", "")
    Set Wk = ThisWorkbook
    WkName = Wk.Name
    Set Wk1 = Workbooks.Add
    Wk1Name = Wk.Path & "\" & "File moi.xlsx"
    For Each TimSh In Wk.Worksheets
        Windows(WkName).Activate
        XoaSheets = Filter(ChuaSheets, TimSh.Name, 1)
        If UBound(XoaSheets) <> 0 Then
            TimSh.Select
            TimSh.Copy after:=Wk1.Sheets(Wk1.Sheets.Count)
        End If
    Next
    ChDir Wk.Path
Wk1.Sheets(Array("sheet1", "sheet2", "sheet3")).Delete
    Wk1.SaveAs Wk1Name, xlOpenXMLWorkbook
    Wk1.Close
    Application.DisplayAlerts = True

End Sub

Thêm 01 đoạn này vào.
Wk1.Sheets(Array("sheet1", "sheet2", "sheet3")).Delete

vanthinh3101 · 26/6/17

robinhsoon đã viết:
Cảm ơn Thầy đúng ý em rồi ạ..!
Nhưng khi xuất ra FIle mới lại có sheet 1, Sheet 2, Sheet 3 nữa?.. Mình tự động bỏ những sheet đó được không Thầy?

Bạn làm theo bài #9 của @phuyen89 nhé!

robinhsoon · 26/6/17

phuyen89 đã viết:

Vẫn bỏ được đó bạn.

PHP:

Sub Add_New_Workbook()
    Application.DisplayAlerts = False
    Dim Wk As Workbook, Wk1 As Workbook
    Dim WkName As String, Wk1Name As String
    Dim ChuaSheets, TimSh, XoaSheets
    ChuaSheets = Array("C", "")
    Set Wk = ThisWorkbook
    WkName = Wk.Name
    Set Wk1 = Workbooks.Add
    Wk1Name = Wk.Path & "\" & "File moi.xlsx"
    For Each TimSh In Wk.Worksheets
        Windows(WkName).Activate
        XoaSheets = Filter(ChuaSheets, TimSh.Name, 1)
        If UBound(XoaSheets) <> 0 Then
            TimSh.Select
            TimSh.Copy after:=Wk1.Sheets(Wk1.Sheets.Count)
        End If
    Next
    ChDir Wk.Path
Wk1.Sheets(Array("sheet1", "sheet2", "sheet3")).Delete
    Wk1.SaveAs Wk1Name, xlOpenXMLWorkbook
    Wk1.Close
    Application.DisplayAlerts = True

End Sub

Thêm 01 đoạn này vào.
Wk1.Sheets(Array("sheet1", "sheet2", "sheet3")).Delete

Em làm được rồi ạ..!

Tks các Thầy đã giúp đỡ ạ...!
Chúc Thầy sức khỏe và thành công

[Giúp] VBA Coppy Sheet sang một file mới và save File mới tại đường dẫn của File nguồn

robinhsoon

Thành viên hoạt động

File đính kèm

phulien1902

GPE - My love

vanthinh3101

Thành viên tích cực

robinhsoon

Thành viên hoạt động

robinhsoon

Thành viên hoạt động

phulien1902

GPE - My love

vanthinh3101

Thành viên tích cực

robinhsoon

Thành viên hoạt động

phuyen89

Thành viên tích cực

vanthinh3101

Thành viên tích cực

robinhsoon

Thành viên hoạt động

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

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

Đếm ngược thời gian