Làm cách nào để tách đơn đặt hàng theo khách

[Hai Lúa Miền Tây]

Chào các anh chị trên diễn đàn, lại một lần nữa làm phiền các anh chị

Em có 1 ý tưởng như sau: Có 1 dữ liệu tổng theo file đính kèm, em muốn có 1 nút click ; sau khi click thì nó sẽ tự động tách đơn đặt hàng theo khách (Mỗi 1 khách là 1 sheet riêng, hoặc 1 workbook riêng thì càng tốt), nếu là sheet trong workbook thì mỗi 1 khách được tách ra trên sheet name cũng ghi tên khách hàng tương ứng.

Cám ơn các anh chị
-Thành viên mới học VBA-

 

[sealand]

Còn 1 số vấn đề nhưng bạn xem có phải không? Nhấn Ctrl+m chạy Macro nhé
Mình thêm 1 sheet danh sách KH cho tiện sử lý.

 

[Hai Lúa Miền Tây]

Cám ơn anh Sealand
Đây đúng là ý của em rồi, nhưng có cách nào tách dữ liệu theo file mẫu (sheet EUN SUNG TEX" không anh ?

 

[sealand]

Bạm kiểm tra giùm đúng chưa nhé (Nếu danh sách khách hàng lưu sẵn thì dùng hàm countif để kiểm tra trong dữ liệu, nếu =0 thì bỏ qua không tạo sheet của KH đó nữa)

 

[Hai Lúa Miền Tây]

Tách sheet

Em muốn hỏi anh một số vấn đề như sau,


Bài viết của anh thật tuyệt vời, Nhưng bởi vì em có một số chỉnh sửa nên nó có một số lổi,

+ Sheet được tách định dạng trang in không giống như định dạng gốc của sheet Temp
+ Sheet KH em đã lookup dữ liệu sang tu Material_Sheet nen co 1 số cell trống cho vùng dữ liệu khachhang, nên khi tách file thì có thêm những sheet mới mà đáng lẽ ra mình không muốn có nó + thêm là sheet Temp không còn định dạng như lúc ban đầu nữa,
+ Em muốn trong cùng 1 workbook này insert thêm vài sheet nữa để sd cho mục đích khác nhưng không đượcNếu được thì có thông báo lỗi), và nếu nhu mình làm việc trên những sheet mới insert và do khi mình nhấn nút "Delete Purchase Order Sheet" trên sheet Material_Sheet thì vô tình những sheet mình insert lúc trước cũng bị xoá mất.
+ Nếu mình sửa tên supliers sang tên mới thì không hiểi sao khi mình tách đơn hàng nó có tự động tách ra sheet mới nhưng dữ liệu không có,
+ Có cách nào mình tách sheet ra mà mỗi một sheet đó là 1 file excel riêng không anh ? vì em lấy file vừa tách đó gửi cho khách hàng, mỗi 1 khách hàng là 1 nơi nên không thể gửi tất cả các sheet đó được, nếu làm thủ công thì rất mất thời gian tách và chỉnh sửa, nếu được thì cú pháp để đặt tên cho file đó là [DoWell Plus - PO Sheet] "Số đơn hàng" - "Tên nhà cung cấp" - "Ngày lập đơn hàng"

Cám ơn anh nhiều

 

[sealand]

1/Các sheet giống nhau vì chép nguyên sheet mà, chỉ có ô ngày phải định dạng lại, bạn xem đ/c trong code theo ý mình.
2/Danh sách là vùng đầy đủ không có ô trống, bạn tham khảo cách tạo DS duy nhất cho DS nhé, sử dụng name động cho vùng "khach"
3/Việc đổi tên KH khi chép bỏ sót dữ liệu: Chắc chắn bạn sửa không đồng bộ cả 2 sheet (KH và Material_Sheet)
4/Bạn muốn bổ xung 1 số sheet trống dự phòng thì chỉ việc mở rộng vùng For...Next....
5/Bạn sửa Supplier thì cũng phải sửa KH.
6/Việc tạo mỗi khách 1 file hoàn toàn có thể, bạn cứ nghiên cứu lúc rảnh mình sẽ làm thử.
7/Việc định dạng Sheet Temp phải chuẩn. Không nên tạo qua nhiều dòng. Code tham khảo thôi chứ chỉ nên có 1 dòng mẫu định dạng thôi sau khi chép sheet sẽ đếm số dòng rồi chèn đúng số lwợng dòng là hợp lý nhất.

 

[Hai Lúa Miền Tây]

Tách đơn đặt hàng

Gửi các anh chị trên diễn đàn,

Mình đã tìm được cách tách mỗi 1 sheet ra thành 1 workbook riêng và lưu nó vào cùng 1 Folder của file gốc nhưng chưa biết tạo name động cho vùng "khach", và làm cách nào để giữ 3 sheet "Suppliers", "Material_Sheet", "Temp" không copy sang workbook mới.
Và cũng chưa biết cách sau khi chép sheet sẽ đếm số dòng rồi chèn đúng số lượng dòng theo sheet Temp
Rất mong nhận được sự giúp đỡ
Cảm ơn các anh chị.

 

[sealand]

Bạn tham khảo cách tạo ds và name bằng code

 

[Hai Lúa Miền Tây]

Tách đơn đạt hàng

Thật cực kỳ hay, cám ơn anh nhiều
Nhưng làm cách nào để giữ 3 sheet "Suppliers", "Material_Sheet", "Temp" không copy sang workbook mới.
Và cũng chưa biết cách sau khi chép sheet sẽ đếm số dòng rồi chèn đúng số lượng dòng theo sheet Temp
Cám ơn anh

 

[sealand]

Bạn điều chỉnh đoạn code sau sẽ không chép 3 sheet gốc nữa: (Xin lỗi chưa test nhé)

Sub Coppy()

Dim Ws As Worksheet

For Each Ws In ThisWorkbook.Worksheets 'loop through the worksheets
If Ws.Name <> "Temp" Or Ws.Name <> "Material_Sheet" Or Ws.Name <> "SUPLIERS" Then
Ws.Copy 'and copy the sheet to a new workbook
End If

Next
End Sub

 

[Hai Lúa Miền Tây]

Tách sheet

Nó báo lỗi như sau anh ơi:

Sub SaveWorksheets()
Dim strPath As String
Dim she As Worksheet
Dim MyDate
Dim S As String
S = [j2]
MyDate = Date
 
strPath = ThisWorkbook.Path
For Each she In ThisWorkbook.Worksheets
 
[COLOR=yellow][B][COLOR=red]If she.Name <> "Temp" Or she.Name <> "Material_Sheet" Or sh.Name <> "SUPLIERS" Then[/COLOR][/B][/COLOR]
 
she.Copy
 
End If
Application.Workbooks(Application.Workbooks.Count).Close _
True, strPath & "\ {DOWELL-PLUS_PO SHEET} - (" & S & ") - {" & she.Name & "} - (" & Format(MyDate, "YYYY-MM-DD)")
 
Application.DisplayAlerts = False
Next
 
End Sub

 

[sealand]

Mình test rồi, chắc chắn được, ban nãy mình gài nhầm code. Bạn thêm code có màu đỏ.(Bạn lưu ý kiểm tra CodeName cua 3 sheet không chép trên file của bạn có phải là Sheet1, sheet2, sheet3 không nhé. Nếu khác thì sửa lại chuỗi:
"SHEET1SHEET2SHEET3"

Sub SaveWorksheets()
   Dim strPath, [B][COLOR=Red]ten[/COLOR][/B] As String
   Dim sh As Worksheet
   Dim MyDate
    
    MyDate = Date
    
   strPath = ThisWorkbook.Path
   For Each sh In ThisWorkbook.Worksheets
   [B][COLOR=Red]ten = UCase(sh.CodeName)[/COLOR][/B]
  [B][COLOR=Red] If InStr(1, "SHEET1SHEET2SHEET3", ten, 0) = 0 Then[/COLOR][/B]
   
       sh.Copy
       Application.Workbooks(Application.Workbooks.Count).Close _
           True, strPath & "\ DOWELL-PLUS_PO SHEET - " & sh.Name & " - (" & Format(MyDate, "YYYY-MM-DD)")
[B][COLOR=Red]  End If[/COLOR][/B]
  ' Application.DisplayAlerts = True
   Next
   
End Sub

 

[Hai Lúa Miền Tây]

Anh Sealand ơi that cưc kỳ chính xác luôn, nhưng sau khi chèn đoạn code trên nó có lúc chạy và có lúc không, em cũng không hiểu tại sao nữa, nhờ anh giúp giùm

[COLOR=black][FONT=Verdana]Sub SaveWorksheets()[/FONT][/COLOR]
[FONT=Verdana][COLOR=black]Dim strPath As String, ten As String[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Dim she As Worksheet[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Dim MyDate[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Dim S As String[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]S = [j2][/COLOR][/FONT]
[FONT=Verdana][COLOR=black]MyDate = Date[/COLOR][/FONT]
 
[FONT=Verdana][COLOR=black]strPath = ThisWorkbook.Path[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]For Each she In ThisWorkbook.Worksheets[/COLOR][/FONT]
 
[FONT=Verdana][COLOR=black]' If she.Name <> "Temp" Or she.Name <> "Material_Sheet" Or sh.Name <> "SUPLIERS" Then[/COLOR][/FONT]
[COLOR=black][FONT=Verdana]ten = UCase(she.CodeName)[/FONT][/COLOR]
[FONT=Verdana][COLOR=black]If InStr(1, "SHEET1SHEET2SHEET3", ten, 0) = 0 Then[/COLOR][/FONT]
[COLOR=black][FONT=Verdana]she.Copy[/FONT][/COLOR]
 
[FONT=Verdana][COLOR=black]' End If[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Application.Workbooks(Application.Workbooks.Count).Close _[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]True, strPath & "\ {DOWELL-PLUS_PO SHEET} - (" & S & ") - {" & she.Name & "} - (" & Format(MyDate, "YYYY-MM-DD)")[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]End If[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Application.DisplayAlerts = False[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Next[/COLOR][/FONT]
 
[FONT=Verdana][COLOR=black]End Sub[/COLOR][/FONT]

Ý tưởng của anh là “7/Việc định dạng Sheet Temp phải chuẩn. Không nên tạo qua nhiều dòng. Code tham khảo thôi chứ chỉ nên có 1 dòng mẫu định dạng thôi sau khi chép sheet sẽ đếm số dòng rồi chèn đúng số lwợng dòng là hợp lý nhất.”em không thể thực hiện được nhờ các anh chị giúp giùm, em cảm ơn


*********

 

[sealand]

1/Lúc chạy lúc không bạn phải kiểm tra code bạn đã viết còn mình chỉ thêm phầm kiểm tra nếu đúng tên sh gốc thì không chép mà thôi (Thực tế mình thử thấy ổn mà).

2/Vấn đề thêm dòng: Sh temp phần nội dung bạn xóa chỉ để 2 dòng 13 và 14 (Xóa từ dòng 15) tiếp là để lại phần chân
Bạn sửa code sau để tự động thêm dòng và đánh số thứ tự

Sub sealand1()
Dim rng As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error Resume Next
For i = 1 To Range("khach").Count
dv = Range("khach").Cells(i, 1)
Sheets.Add
   
  Sheets("Temp").Select
  Cells.Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets(dv).Select
    Range("A1").Select
    ActiveSheet.Paste
With Sheets(dv)

        .[c6] = dv
        .[c7] = Sheet3.[j2]
        .[c8] = Sheet3.[j3]
        .[c8].NumberFormat = "[$-409]mmmm d, yyyy;@"
        .[H9] = Sheet3.[O2] & " (BUYER: " & Sheet3.[F3] & ")"
        .[C9] = ([C9])
k = 13
For j = 5 To Sheet3.[a4].CurrentRegion.Rows.Count
If Sheet3.Cells(j, 13) = dv Then
       [B][COLOR=Red] .Cells(k, 1) = k - 12[/COLOR][/B]                'Để đánh số thứ tự tại cột 1

        .Cells(k, 3) = Sheet3.Cells(j, 2)
        .Cells(k, 4) = Sheet3.Cells(j, 3)
        .Cells(k, 5) = Sheet3.Cells(j, 4)
        .Cells(k, 6) = Sheet3.Cells(j, 7)
        .Cells(k, 7) = Sheet3.Cells(j, 6)
        .Cells(k, 8) = Sheet3.Cells(j, 8)
        .Cells(k, 9) = Sheet3.Cells(j, 10)
        .Cells(k, 10) = Sheet3.Cells(j, 9)
        .[a1].Select
k = k + 1
    [B][COLOR=Red].Cells(k, 1).EntireRow.Insert Shift:=xlDown[/COLOR][/B]        'Chèn thêm dòng

End If
Next
End With
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[Hai Lúa Miền Tây]

Cám ơn anh nhiều,

Em them đoạn code vào để chỉnh trang nhưng nó chạy lâu quá, anh có cách nào cho nó chạy nhanh hơn không anh ?

-----
Sub sealand1()
Dim rng As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim D As Date
D = 7
On Error Resume Next
For i = 1 To Range("khach").Count
dv = Range("khach").Cells(i, 1)
Sheets.Add

Sheets("Temp").Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Sheets(dv).Select
Range("A1").Select
ActiveSheet.Paste
With Sheets(dv)
.[c6] = dv
.[c7] = Sheet3.[j2]
.[c8] = Sheet3.[j3]
.[c8].NumberFormat = "[$-409]mmmm d, yyyy;@"
.[H9] = Sheet3.[O2] & " (BUYER: " & Sheet3.[F3] & ")"
.[c9] = ([c9])

If [c9] <> "DOWELL PLUS - SEOUL" Then
[c8] = [c8] + D
End If

k = 13
For j = 5 To Sheet3.[a4].CurrentRegion.Rows.Count
If Sheet3.Cells(j, 13) = dv Then
.Cells(k, 2) = k - 12 '©¢? ©¢anh s? th? t? t?i c?t 1

.Cells(k, 3) = Sheet3.Cells(j, 2)
.Cells(k, 4) = Sheet3.Cells(j, 3)
.Cells(k, 5) = Sheet3.Cells(j, 4)
.Cells(k, 6) = Sheet3.Cells(j, 7)
.Cells(k, 7) = Sheet3.Cells(j, 6)
.Cells(k, 8) = Sheet3.Cells(j, 8)
.Cells(k, 9) = Sheet3.Cells(j, 10)
.Cells(k, 10) = Sheet3.Cells(j, 9)


.[a1].Select
k = k + 1
.Cells(k, 1).EntireRow.Insert Shift:=xlDown 'Chen them dong



With ActiveSheet.PageSetup


'.CenterHeader = "&14PURCHASE ORDER SHEET" & Chr(10) & "AS OF &D"
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.2)
.BottomMargin = Application.InchesToPoints(0.2)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
'.Orientation = xlLandscape
.Orientation = xlPortrait
.CenterHorizontally = True
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1

End With

End If
Next
End With
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Sheet3.Activate
End Sub
------

 

[sealand]

Tại sao bạn lại phải làm các động tác định dạng ở đây, bạn nên định dạng sẵn ở temp và và nó sẽ chép đúng như vậy cho các trang đích. Bạn nên xóa bớt những dòng không cần thiết.

Bạn chèn vậy chậm là phải vì cứ chép xong 1 dòng lại Page setup 1 lần nên Page setup thừa quá nhiều lần. Việc Page setup ở file này cũng không ổn. Vì còn 1 động tác là chép từ sheet ở file này ra riêng từng file. Vậy thì sheet ở file đích chưa được page setup. Phải định dạng ở file đích cơ.Mình đề xuất thế này (Xin lỗi chưa test)

Sub JR_COPY_SAVE_SELECTED_SHEETS()
     
    Dim myfilenameFULL As String
    Dim MyDate
    Application.DisplayAlerts = False
    MyDate = Date
    myfilenameFULL = myFileName _
    & " - " & Sheet4.Name _
    & " - (" & Format(MyDate, "YYYY-MM-DD)") _
    & myFileType_EXCEL
     
      Sheets(Array(Sheet4.Name)).Copy
           
      Sheets(Array(Sheet5.Name)).Copy
      
      [COLOR=red][B]With ActiveSheet.PageSetup
    
    
'.CenterHeader = "&14PURCHASE ORDER SHEET" & Chr(10) & "AS OF &D"
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.2)
.BottomMargin = Application.InchesToPoints(0.2)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
'.Orientation = xlLandscape
.Orientation = xlPortrait
.CenterHorizontally = True
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        
    End With[/B][/COLOR]

     ActiveWorkbook.SaveAs Filename:=myfilenameFULL
    Application.DisplayAlerts = True
    'ActiveWorkbook.Close FALSE
End Sub

 

[Hai Lúa Miền Tây]

chỉnh trang

1). Em test rồi, có khác chút xíu là nếu như em chưa đổi code giống như anh thì thời gian cho việc tách sheet lâu hơn thời gian tách file, và ngược lại. Tóm lại thời gian của 2 cách đều mất giống nhau, nhờ anh giúm em với.
2). Em có vấn đề thế này: khi mình tách sheet, đếm số dòng và chèn thêm dòng và đánh số thứ tự cho dòng có dữ liệu thì ô được đánh số thứ tự từ số 2 trở đi không được đóng khung (nếu có 1 dòng số tt là 1 thì không sao), nhờ anh giúm giùm
Em cảm ơn nhiều

 

[sealand]

Mình sẽ kiểm tra lại việc Page setup sau.
Riêng kẻ ô nếu việc chép không ổn định ta có thể thêm như sau:

Sub sealand1()
............................................................
k = k + 1
 .Cells(k, 1).EntireRow.Insert Shift:=xlDown        'Chèn thêm dòng
[COLOR=Blue]Range(Cells(k, 1), Cells(k, 2)).Merge[/COLOR]
[COLOR=Blue]  With Range(Cells(k, 1), Cells(k, 2)).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With[/COLOR]

..........................................................
End Sub

P/s: Thêm dòng sau trước With nhé
Range(Cells(k, 1), Cells(k, 2)).Merge

 

[sealand]

Mình đã test và thấy ổn định. Để PageSetup cài vào Sub sau (Cần Setup ra sao bạn thêm vào):

Sub SaveWorksheets()
.............................................
[B][COLOR=Red]Application.ScreenUpdating = False[/COLOR][/B]
.............................................    
   strPath = ThisWorkbook.Path
   For Each sh In ThisWorkbook.Worksheets
   [B][COLOR=Red]With sh.PageSetup
                  .Orientation = xlLandscape
                  .LeftMargin = 0.25
                  .RightMargin = 0.25
End with[/COLOR][/B]

   ten = UCase(sh.CodeName)
   If InStr(1, "SHEET1SHEET2SHEET3", ten, 0) = 0 Then
   
       sh.Copy
      ...............................................
[B][COLOR=Red]Application.ScreenUpdating = True[/COLOR][/B]
  End Sub

 

[Hai Lúa Miền Tây]

Tuyệt vời anh Sealand ơi, nhưng nếu được thêm thanh Progess bar trên giữa màn hình trong khi chờ đợi thì càng tuyệt vời phải không anh.