[Help] VBA Tách File (1 người xem)

[ngoctuyen1995]

Thân Chào cả Nhà GPE...!

Em có vấn đề này nhờ các Thầy giúp với ạ.
Hiện tại em có File data gồm các cột
Công việc:
Khi gọi Macro thì sẽ tự tìm đến Hàng A1 và tìm tới vị trí cột có tên là Team in charge và tự tách data
Ví dụ:
Trong cột Team In Charge em có 01.HCM thì Macro sẽ tự tách tất cả cột và hàng có tên là 01. HCM ra một File riêng, và tương tự làm cho các giá trị khác... (File data gốc vẫn giữ)

Mong các Thầy giúp đỡ ạ..! em cảm ơn ạ.

 

[Lê Duy Thương]

Thân Chào cả Nhà GPE...!

Em có vấn đề này nhờ các Thầy giúp với ạ.
Hiện tại em có File data gồm các cột
Công việc:
Khi gọi Macro thì sẽ tự tìm đến Hàng A1 và tìm tới vị trí cột có tên là Team in charge và tự tách data
Ví dụ:
Trong cột Team In Charge em có 01.HCM thì Macro sẽ tự tách tất cả cột và hàng có tên là 01. HCM ra một File riêng, và tương tự làm cho các giá trị khác... (File data gốc vẫn giữ)

Mong các Thầy giúp đỡ ạ..! em cảm ơn ạ.

tách thành file hay thành sheet ?

 

[ngoctuyen1995]

tách thành file hay thành sheet ?

Dạ! Thành FIle ạ
Mong Thầy giúp đỡ ạ!

 

[Lê Duy Thương]

dạ! Thành FIle ạ
Cảm ơn Thầy đã quan tâm ạ!

thứ nhất bạn nên thay dấu chấm trong cột Team in charge thành dấu gạch chân để khi xuất thành file sẽ tránh được lỗi.
thứ 2 giải nén file vào desktop hay ổ D rồi mở file data total lên -- bấm nut là có kq
code

Option Explicit
Function SheetExists(ByVal SheetName As String) As Boolean
  On Error Resume Next
  SheetExists = Not Sheets(SheetName) Is Nothing
End Function
Private Function UniqueList(Range As Range)
  Dim Clls As Range
  With CreateObject("Scripting.Dictionary")
    For Each Clls In Range
      If Not IsEmpty(Clls) And Not .Exists(Clls.Value) Then .Add Clls.Value, ""
    Next Clls
    UniqueList = .Keys
  End With
End Function
Sub Creat_sheet()
Dim Item, Items As Range
Set Items = Sheet1.Range("f9:f6500")
    For Each Item In UniqueList(Items)
      If SheetExists(CStr(Item)) = False Then
         Sheets.Add(After:=Sheets(Sheets.Count)).Name = CStr(Item)
      End If
    Next
 Application.Goto Sheet1.[A1], True
 Call Copy_data_to_newsheet
End Sub

Sub Copy_data_to_newsheet()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
  Dim Sh As Worksheet
  For Each Sh In Worksheets
   If Sh.Name <> "Data" Then
   Sh.Cells.Clear
   Sh.Range("A1") = Sheets("Data").[f8]
   Sh.Range("A2").Value = Sh.Name
   Sheet1.Range("A8:P5000").AdvancedFilter 2, Sh.Range("A1:A2"), Sh.Range("A8"), False
   Sh.Range("A1:A2").Clear
   Sh.Cells.EntireColumn.AutoFit
  Sh.Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Sh.Name, 51
   ActiveWorkbook.Close
  End If
  Next

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Call Delete_sheet
End Sub


Sub Delete_sheet()
 Dim Sh As Worksheet, DelSh As Worksheet
  Application.DisplayAlerts = False
  On Error Resume Next
    Set Sh = Sheets("data")
  For Each DelSh In ThisWorkbook.Worksheets
    If DelSh.Name <> Sh.Name Then DelSh.Delete
     Next
End Sub

 

[Quang_Hải]

Thân Chào cả Nhà GPE...!

Em có vấn đề này nhờ các Thầy giúp với ạ.
Hiện tại em có File data gồm các cột
Công việc:
Khi gọi Macro thì sẽ tự tìm đến Hàng A1 và tìm tới vị trí cột có tên là Team in charge và tự tách data
Ví dụ:
Trong cột Team In Charge em có 01.HCM thì Macro sẽ tự tách tất cả cột và hàng có tên là 01. HCM ra một File riêng, và tương tự làm cho các giá trị khác... (File data gốc vẫn giữ)

Mong các Thầy giúp đỡ ạ..! em cảm ơn ạ.

Sub Tach_Ra_Nhieu_File()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Dic As Object
Dim i As Long, Data(), Sdata As Range, Ma As Variant
Set Dic = CreateObject("scripting.dictionary")
Data = Range([A2], [A65536].End(3)).Resize(, 7).Value
Set Sdata = Range([A1], [A65536].End(3)).Resize(, 7)
For i = 1 To UBound(Data)
   If Data(i, 6) <> "" Then Dic.Item(Data(i, 6)) = ""
Next
For Each Ma In Dic.keys
   With Sdata
      .AutoFilter 6, Ma
      .SpecialCells(12).Copy
      Workbooks.Add
      With ActiveWorkbook
         .ActiveSheet.Name = Ma
         .ActiveSheet.[A1].PasteSpecial 1
         .ActiveSheet.[A:G].Columns.AutoFit
         .SaveAs ThisWorkbook.Path & "\" & Ma & ".xlsx", xlWorkbookDefault
         .Close True
      End With
      .AutoFilter
   End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

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

Dạ! Thành FIle ạ
Mong Thầy giúp đỡ ạ!

BẠn giải nén và vào folder giải nén, chạy file nhé.

 

[ngoctuyen1995]

Sub Tach_Ra_Nhieu_File()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Dic As Object
Dim i As Long, Data(), Sdata As Range, Ma As Variant
Set Dic = CreateObject("scripting.dictionary")
Data = Range([A2], [A65536].End(3)).Resize(, 7).Value
Set Sdata = Range([A1], [A65536].End(3)).Resize(, 7)
For i = 1 To UBound(Data)
   If Data(i, 6) <> "" Then Dic.Item(Data(i, 6)) = ""
Next
For Each Ma In Dic.keys
   With Sdata
      .AutoFilter 6, Ma
      .SpecialCells(12).Copy
      Workbooks.Add
      With ActiveWorkbook
         .ActiveSheet.Name = Ma
         .ActiveSheet.[A1].PasteSpecial 1
         .ActiveSheet.[A:G].Columns.AutoFit
         .SaveAs ThisWorkbook.Path & "\" & Ma & ".xlsx", xlWorkbookDefault
         .Close True
      End With
      .AutoFilter
   End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Sub Tach_Ra_Nhieu_File()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Dic As Object
Dim i As Long, Data(), Sdata As Range, Ma As Variant
Set Dic = CreateObject("scripting.dictionary")
Data = Range([A2], [A65536].End(3)).Resize(, 7).Value
Set Sdata = Range([A1], [A65536].End(3)).Resize(, 7)
For i = 1 To UBound(Data)
   If Data(i, 6) <> "" Then Dic.Item(Data(i, 6)) = ""
Next
For Each Ma In Dic.keys
   With Sdata
      .AutoFilter 6, Ma
      .SpecialCells(12).Copy
      Workbooks.Add
      With ActiveWorkbook
         .ActiveSheet.Name = Ma
         .ActiveSheet.[A1].PasteSpecial 1
         .ActiveSheet.[A:G].Columns.AutoFit
         .SaveAs ThisWorkbook.Path & "\" & Ma & ".xlsx", xlWorkbookDefault
         .Close True
      End With
      .AutoFilter
   End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Em cảm ởn Thầy code rất hay ạ... Nhưng Teamplate cột Team In chager của em thì nó thường bị thây đổi nên không có định, Thầy có thể giúp em sửa lại là code sẽ tự tìm đến cột Team InChager được không ạ... và lúc xuất ra File thay vì tên File là 01. HCM thì em có thể tự gán thêm chữ Logic_HCM được không ạ

 

[ngoctuyen1995]

BẠn giải nén và vào folder giải nén, chạy file nhé.

Em cảm ởn Thầy code rất hay ạ... Nhưng Teamplate cột Team In chager của em thì nó thường bị thây đổi nên không có định, Thầy có thể giúp em sửa lại là code sẽ tự tìm đến cột Team InChager được không ạ... và lúc xuất ra File thay vì tên File là 01. HCM thì em có thể tự gán thêm chữ Logic_HCM được không ạ

 

[Lê Duy Thương]

Em cảm ởn Thầy code rất hay ạ... Nhưng Teamplate cột Team In chager của em thì nó thường bị thây đổi nên không có định, Thầy có thể giúp em sửa lại là code sẽ tự tìm đến cột Team InChager được không ạ... và lúc xuất ra File thay vì tên File là 01. HCM thì em có thể tự gán thêm chữ Logic_HCM được không ạ

ĐƯƠNG NHIÊN LÀ ĐƯỢC NHƯNG LỠ TÊN SHEET CÓ 1-2 KÝ TỰ THÌ SAO ?
XEM FILE

 

[Quang_Hải]

Em cảm ởn Thầy code rất hay ạ... Nhưng Teamplate cột Team In chager của em thì nó thường bị thây đổi nên không có định, Thầy có thể giúp em sửa lại là code sẽ tự tìm đến cột Team InChager được không ạ... và lúc xuất ra File thay vì tên File là 01. HCM thì em có thể tự gán thêm chữ Logic_HCM được không ạ

Mọi thứ đều có thể nếu như chúng ta muốn. Với GPE thì yêu cầu của bạn là chuyện bình thường nhưng Template mà bị thay đổi liên tục thì sao gọi là Template??? Nghe vô lý quá xá

 

[VetMini]

Mọi thứ đều có thể nếu như chúng ta muốn. Với GPE thì yêu cầu của bạn là chuyện bình thường nhưng Template mà bị thay đổi liên tục thì sao gọi là Template??? Nghe vô lý quá xá

Template nếu dùng như một dạng vỹ mô (metaform) thì nó có thể thay đổi. Và code có cách để nhận biết dạng mới của nó.
Đương nhiên ba cái đồ vỹ mô cũng phải có quy luật để không bị vượt ngoài khả năng của code. Và khả năng GPE có code được hay không hoàn toàn tuỳ thuộc vào quy luật template của chủ thớt. (trước mắt thì thấy cách đặt câu hỏi đã e rằng chủ thớt chả hiểu quy luật là cái gì)

 

[ngoctuyen1995]

Template nếu dùng như một dạng vỹ mô (metaform) thì nó có thể thay đổi. Và code có cách để nhận biết dạng mới của nó.
Đương nhiên ba cái đồ vỹ mô cũng phải có quy luật để không bị vượt ngoài khả năng của code. Và khả năng GPE có code được hay không hoàn toàn tuỳ thuộc vào quy luật template của chủ thớt. (trước mắt thì thấy cách đặt câu hỏi đã e rằng chủ thớt chả hiểu quy luật là cái gì)

Dạ! em hiểu rồi ạ...Cảm ơn Thầy đã quan tâm ạ, em sẽ ghi nhớ điều này ạ.

 

[ngoctuyen1995]

ĐƯƠNG NHIÊN LÀ ĐƯỢC NHƯNG LỠ TÊN SHEET CÓ 1-2 KÝ TỰ THÌ SAO ?
XEM FILE

Cảm ơn Thầy rất nhiều..
Đúng ý của em rồi ạ.. Chúc Các Thầy sức khỏe và Thành Công..