Lưu nhiều sheet theo đường dẫn khác nhau

adult · 24/8/10

Chào các bác!
Em có vấn đề cần các anh chị em trên diễn đàn gíup đỡ:
Em có 1 bảng như sau :

A......... B....................................... C.............................. D
No........ Name.............................. Dỉr Path.................. File name
1......... Nguyen Van A.................. D:\Khoi 6.................. Nguyen Van A.xls
2......... Nguyen Van B.................. D:\Khoi 7.................. Nguyen Van B.xls
3......... Nguyen Van C.................. D:\Khoi 8.................. Nguyen Van C.xls
4......... Nguyen Van D.................. D:\Khoi 9.................. Nguyen Van D.xls

Các tên trong cột B được lấy từ tên của 4 sheet có trong file
Các a chị giúp em lưu các tên sheet trong cột B sang 1 file mới theo đường dẫn tại cột C nhé. Mọi người có thể xem trong file đính kèm.
Thanks các anh/ chị nhiều!

ndu96081631 · 24/8/10

adult đã viết:
Chào các bác!
Em có vấn đề cần các anh chị em trên diễn đàn gíup đỡ:
Em có 1 bảng như sau :

A......... B....................................... C.............................. D
No........ Name.............................. Dỉr Path.................. File name
1......... Nguyen Van A.................. D:\Khoi 6.................. Nguyen Van A.xls
2......... Nguyen Van B.................. D:\Khoi 7.................. Nguyen Van B.xls
3......... Nguyen Van C.................. D:\Khoi 8.................. Nguyen Van C.xls
4......... Nguyen Van D.................. D:\Khoi 9.................. Nguyen Van D.xls

Các tên trong cột B được lấy từ tên của 4 sheet có trong file
Các a chị giúp em lưu các tên sheet trong cột B sang 1 file mới theo đường dẫn tại cột C nhé. Mọi người có thể xem trong file đính kèm.
Thanks các anh/ chị nhiều!

Cũng đơn giản thôi mà:

PHP:

Sub Main()
  Dim Clls As Range
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  With ThisWorkbook.Sheets("Sheet1")
    For Each Clls In .Range(.[B2], .[B65536].End(xlUp))
      If Dir(Clls(, 2).Value, 16) = "" Then MkDir Clls(, 2).Value
      .Parent.Sheets(Clls.Value).Copy
      ActiveWorkbook.SaveAs Clls(, 2).Value & "\" & Clls(, 3).Value
      ActiveWorkbook.Close (True)
    Next
  End With
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

adult · 24/8/10

Cảm ơn anh ndu96081631 nhiều lắm
Anh có thể giúp em điều chỉnh thêm code trên theo hướng:
1. Nếu tên sheet trong cột B không có trong file thì hịên thông báo" sheet không tồn tại. Bạn có muốn tiếp tục không?" Bấm Yes thì sẽ tiếp tục tách hàng tiếp theo. No thì ngưng code
2. Nếu đường dẫn trong cột C trống thì sheet được tách sẽ lưu theo thư mục file đang lưu trữ
3. Nếu có thể thì hiện luôn danh sách đã tách và lưu thành công (cái này anh khuyến mãi, có thì tốt, không có cũng không sao, hihii)
Cám ơn anh đã giúp em nhé!

ndu96081631 · 24/8/10

adult đã viết:
Cảm ơn anh ndu96081631 nhiều lắm
Anh có thể giúp em điều chỉnh thêm code trên theo hướng:
1. Nếu tên sheet trong cột B không có trong file thì hịên thông báo" sheet không tồn tại. Bạn có muốn tiếp tục không?" Bấm Yes thì sẽ tiếp tục tách hàng tiếp theo. No thì ngưng code
2. Nếu đường dẫn trong cột C trống thì sheet được tách sẽ lưu theo thư mục file đang lưu trữ
3. Nếu có thể thì hiện luôn danh sách đã tách và lưu thành công (cái này anh khuyến mãi, có thì tốt, không có cũng không sao, hihii)
Cám ơn anh đã giúp em nhé!

Thêm 1 Function thế này:

PHP:

Function SheetExist(WorkSheetName As String) As Boolean
  On Error Resume Next
  SheetExist = Not ThisWorkbook.Sheets(WorkSheetName) Is Nothing
End Function

Và sửa Sub Main lại thế này:

Mã:

Sub Main()
  Dim Clls As Range, Ans As Long, sPath As String, i As Long, Arr()
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  With ThisWorkbook.Sheets("Sheet1")
    For Each Clls In .Range(.[B2], .[B65536].End(xlUp))
      If SheetExist(Clls.Value) Then
        If Clls(, 2).Value = "" Then
          sPath = ThisWorkbook.Path
        Else
          If Dir(Clls(, 2).Value, 16) = "" Then MkDir Clls(, 2).Value
          sPath = Clls(, 2).Value
        End If
        .Parent.Sheets(Clls.Value).Copy
        ActiveWorkbook.SaveAs sPath & "\" & Clls(, 3).Value
        ActiveWorkbook.Close (True)
        ReDim Preserve Arr(i)
        Arr(i) = sPath & "\" & Clls(, 3).Value
        i = i + 1
      Else
        Ans = MsgBox("Sheet '" & Clls.Value & "' không ton tai!" & vbLf & _
                       "Ban co muon tiep tuc khong?", vbYesNo, "THÔNG BÁO!")
        If Ans = vbNo Then GoTo ExitSub
      End If
    Next
  End With
ExitSub:
  If i Then MsgBox "Các file luu thành công:" & vbLf & Join(Arr, vbLf)
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

adult · 17/9/10

ndu96081631 đã viết:

Thêm 1 Function thế này:

PHP:

Function SheetExist(WorkSheetName As String) As Boolean
  On Error Resume Next
  SheetExist = Not ThisWorkbook.Sheets(WorkSheetName) Is Nothing
End Function

Và sửa Sub Main lại thế này:

Mã:

Sub Main()
  Dim Clls As Range, Ans As Long, sPath As String, i As Long, Arr()
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  With ThisWorkbook.Sheets("Sheet1")
    For Each Clls In .Range(.[B2], .[B65536].End(xlUp))
      If SheetExist(Clls.Value) Then
        If Clls(, 2).Value = "" Then
          sPath = ThisWorkbook.Path
        Else
          If Dir(Clls(, 2).Value, 16) = "" Then MkDir Clls(, 2).Value
          sPath = Clls(, 2).Value
        End If
        .Parent.Sheets(Clls.Value).Copy
        ActiveWorkbook.SaveAs sPath & "\" & Clls(, 3).Value
        ActiveWorkbook.Close (True)
        ReDim Preserve Arr(i)
        Arr(i) = sPath & "\" & Clls(, 3).Value
        i = i + 1
      Else
        Ans = MsgBox("Sheet '" & Clls.Value & "' không ton tai!" & vbLf & _
                       "Ban co muon tiep tuc khong?", vbYesNo, "THÔNG BÁO!")
        If Ans = vbNo Then GoTo ExitSub
      End If
    Next
  End With
ExitSub:
  If i Then MsgBox "Các file luu thành công:" & vbLf & Join(Arr, vbLf)
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

Bác ơi! code của bác hay lắm nhưng mà sau khi test tách khoảng 900 sheet thì bị lỗi ngay tức khắc. Bác có cách nào khắc phục không ah?
Nó chỉ cho phép tách khoảng 150 sheet, khi hiển thị 150 tên sheet lên msgbox thì không đủ, bác có cách nào tạo cho nó 1 scroll down không?
Cám ơn bác nhiều nhé.!

ndu96081631 · 17/9/10

adult đã viết:
Bác ơi! code của bác hay lắm nhưng mà sau khi test tách khoảng 900 sheet thì bị lỗi ngay tức khắc. Bác có cách nào khắc phục không ah?
Nó chỉ cho phép tách khoảng 150 sheet, khi hiển thị 150 tên sheet lên msgbox thì không đủ, bác có cách nào tạo cho nó 1 scroll down không?
Cám ơn bác nhiều nhé.!

Thì bạn đừng dùng MsgBox nữa ---> Thiếu chi Control có thể thay thế: UserForm, Application.Assistant.DoAlert... vân vân...
Thí nghiệm đi
Còn việc code lỗi khi file chứa nhiều sheet thì khó nói lắm! Trên diễn đàn cũng đã từng bàn vụ này và cũng không chắc được chính xác là bao nhiêu sheet thì sẽ bị lỗi đâu! Good luck!

adult · 20/9/10

THanks Bác nhé. Hiện qui trình của em là :
1. Tách toàn bộ sheet cần
2. Lưu ra file
3. Delete các sheet đã tách
===> Như vậy thì ngay từ bước 1 thực hiên xong tách được vài trăm sheet chỉ để ngắm thôi, khi click code tiếp theo sẽ bị lỗi.
Nhờ bác giúp cho 1 qui trình khác:
1. Tách sheet 1
2. Lưu Sheet 1 ra file theo đường dẫn
3. Delete Sheet 1
Lặp lại thứ tự trên cho sheet 2
1. Tách sheet 2
2. Lưu Sheet 2 ra file theo đường dẫn
3. Delete Sheet 2
Cứ thế cho đến sheet n. Em nghĩ như vậy sẽ tránh được tình trạng trong file excel chứa quá nhiều sheet dễ dẫn đến lỗi.
Đây là code em sử dụng để tách sheet:

Mã:

Sub SplitSheet()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error Resume Next
Dim sh As Worksheet
    'Chon vung muon tach sheet va dat ten
    Selection.Name = "List"
    For i = 1 To Range("List").Count
    dv = Range("List").Cells(i, 1)
       Sheets.Add
       If Err.Number <> 0 Then MsgBox "Sheet " & Sheets(dv).Name & " dang ton tai. Xin vui long kiem tra lai!"
       Sheet1.Cells.Copy
       Sheets(dv).Paste
       Application.CutCopyMode = False
    Next
For Each sh In ThisWorkbook.Sheets
     If UCase(sh.CodeName) <> "SHEET1" And UCase(sh.CodeName) <> "SHEET2" _
     And UCase(sh.CodeName) <> "SHEET3" Then
        'Lay ten sheet lam dieu kien loc ten
        With sh
            .Select
            .Range("d3").Value = .Name
        End With
        'Xac dinh ten sheet moi tach ra
    sh.Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    ActiveWindow.DisplayGridlines = False
    ActiveWindow.DisplayHeadings = False
    sh.[A1].Select
    End If
  Next
Sheet3.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Bác tham khảo và giúp em nhé!
Thanks so much!

ndu96081631 · 20/9/10

adult đã viết:
THanks Bác nhé. Hiện qui trình của em là :
1. Tách toàn bộ sheet cần
2. Lưu ra file
3. Delete các sheet đã tách
===> Như vậy thì ngay từ bước 1 thực hiên xong tách được vài trăm sheet chỉ để ngắm thôi, khi click code tiếp theo sẽ bị lỗi.
Nhờ bác giúp cho 1 qui trình khác:
1. Tách sheet 1
2. Lưu Sheet 1 ra file theo đường dẫn
3. Delete Sheet 1
Lặp lại thứ tự trên cho sheet 2
!

Tách ra 1 sheet, lưu rồi xóa sheet vừa tách <--- Công đoạn này có phải dư không ta? Sao không tách ra 1 Workbook mới luôn, lưu và đóng lại là xong!

adult · 20/9/10

ndu96081631 đã viết:
Tách ra 1 sheet, lưu rồi xóa sheet vừa tách <--- Công đoạn này có phải dư không ta? Sao không tách ra 1 Workbook mới luôn, lưu và đóng lại là xong!

Ah. Có thể là em ghi nhầm ý, sorry bác.
Tách sheet ra 1 workbook mới rồi save. Sau đó delete sheet vừa tách đó ạh.

adult · 21/9/10

ANh ndu96081631 ơi!
Anh vẫn chưa tìm được giải pháp để giúp em àh?

ThuNghi · 21/9/10

adult đã viết:
Ah. Có thể là em ghi nhầm ý, sorry bác.
Tách sheet ra 1 workbook mới rồi save. Sau đó delete sheet vừa tách đó ạh.

Vấn đề là cái sh tách ra chứa cái gì trong đó. Add một sh trắng có tên là shName và lưu thành file...
Tạm thời bạn thay câu sau trong code của ND

.Parent.Sheets(Clls.Value).Copy

thành

.Parent.Sheets(Clls.Value).Move

xem thử thế nào.
và để tránh tình trạng nó bị treo vì tách nhiều sh thì mình thêm thử câu sau
Thay

PHP:

Arr(i) = sPath & "\" & Clls(, 3).Value
        i = i + 1
      Else

thành

PHP:

Arr(i) = sPath & "\" & Clls(, 3).Value
        i = i + 1
if i mod 20 =0 then
ActiveWorkbook.Save
end if
      Else

Chưa test cụ thể nên chưa biết OK. Bạn làm thử.

adult · 22/9/10

Cảm ơn Anh Thunghi! em chỉnh lại file, các tên sheet được tách mới không sử dụng unicode sẽ không bị lỗi. Nếu đổi thành move và thêm 20 book save 1 lần thì bị lỗi ah.
Em sẽ nghiên cứu tiếp. Nếu có gì thắc mắc mong các anh chị giúp đỡ nhé.
Thanks NDU & Thunghi

ngoctuan277 · 24/12/10

Bạn ndu ơi. Xin bỏ chút thời gian làm giúp bài này cho mình với. Trong Flie gửi kèm. mình tại Shee N-X khi nhập các dữ liệu vào xong ta cilck nút ghi dữ liệu thì dữ liệu trong nội dung phiếu xuất or nhập sẽ được ghi vào những sheet tương ứng như bảng ghi có 152 hoặc theo dõi vật tư nhập xuất cho từng công trình. những mong muốn cụ thể mình đã kèm theo flie. Bạn giúp mình nhé.
Mình rất muốn gặp bạn qua điện thoại để trao đổi cụ thể hơn nhưng tìm hoài mà không thầy số ĐT của bạn. Cho mình xin số ĐT luôn nhé ban.
Mail: ngoctuan277@gmail.com .

newhope2005 · 25/12/10

ngoctuan277 đã viết:
Bạn ndu ơi. Xin bỏ chút thời gian làm giúp bài này cho mình với. Trong Flie gửi kèm. mình tại Shee N-X khi nhập các dữ liệu vào xong ta cilck nút ghi dữ liệu thì dữ liệu trong nội dung phiếu xuất or nhập sẽ được ghi vào những sheet tương ứng như bảng ghi có 152 hoặc theo dõi vật tư nhập xuất cho từng công trình. những mong muốn cụ thể mình đã kèm theo flie. Bạn giúp mình nhé.
Mình rất muốn gặp bạn qua điện thoại để trao đổi cụ thể hơn nhưng tìm hoài mà không thầy số ĐT của bạn. Cho mình xin số ĐT luôn nhé ban.
Mail: ngoctuan277@gmail.com .

Bạn ơi! Ai cũng muốn xin số điện thoại để “sầu riêng” thì mọi người học hỏi sao được
Các vấn đề nên trao đổi trên diễn đàn này đi. Cho tui và các bạn khác còn có cơ hội xem chứ.
Hơn nữa, ai cũng xin số để “riêng” một chút…thì các “cao nhân” cũng “tèo” mất.

Bài của tớ post lên cũng khá lâu rùi nhưng phải kiên nhẫn chờ đợi thôi.

quick87 · 5/5/14

Nhờ các anh chị hỗ trợ viết code giúp em trong trường hợp này ạ,

File tổng hợp có nhiều khoản mục, em muốn tách từng khoản mục thành từng 1 file mới với tên và thư mục lưu được định nghĩa cho trước.
Mong sớm nhận được hồi âm của các anh chị.

Cảm ơn mọi người !

Lưu nhiều sheet theo đường dẫn khác nhau

adult

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

File đính kèm

ndu96081631

Huyền thoại GPE

File đính kèm

adult

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

ndu96081631

Huyền thoại GPE

File đính kèm

adult

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

ndu96081631

Huyền thoại GPE

adult

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

ndu96081631

Huyền thoại GPE

adult

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

adult

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

ThuNghi

Hãy cho rồi sẽ nhận!

adult

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

ngoctuan277

Thành viên mới

newhope2005

Thành viên mới

quick87

(/ội...

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

Facebook

Group

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