làm sao tách ra và save từng workbook theo PartNumber dùng VBA

mccdgxch · 1/11/14

Chào anh chị,

em có một worksheet nầy cần anh chị giúp đở.

[TABLE="width: 500"]
[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Year[/TD]
[TD]Make[/TD]
[TD]Model[/TD]
[TD]VehicleType[/TD]
[TD]PartNumber[/TD]
[TD]PartType[/TD]
[TD]Position[/TD]
[TD]OEM[/TD]
[TD]Color[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]1990[/TD]
[TD]Chevrolet[/TD]
[TD]Cobalt[/TD]
[TD]Car[/TD]
[TD]GM2007MA-FL[/TD]
[TD]11315[/TD]
[TD]Front Left[/TD]
[TD]22722[/TD]
[TD]Blue[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]1991[/TD]
[TD]Chevrolet[/TD]
[TD]Cobalt[/TD]
[TD]Car[/TD]
[TD]GM2007MA-FL[/TD]
[TD]11315[/TD]
[TD]Front Left[/TD]
[TD]22722[/TD]
[TD]Blue[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]1992[/TD]
[TD]Chevrolet[/TD]
[TD]Cobalt[/TD]
[TD]Car[/TD]
[TD]GM2007MA-FL[/TD]
[TD]11315[/TD]
[TD]Front Left[/TD]
[TD]22722[/TD]
[TD]Blue[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]2002[/TD]
[TD]Pontiac[/TD]
[TD]Vibe[/TD]
[TD]Car[/TD]
[TD]PT3225ME-RL[/TD]
[TD]21547[/TD]
[TD]Rear Left[/TD]
[TD]23564[/TD]
[TD]Yellow[/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]2001[/TD]
[TD]Pontiac[/TD]
[TD]Vibe[/TD]
[TD]Car[/TD]
[TD]PT3225ME-RL[/TD]
[TD]21547[/TD]
[TD]Rear Left[/TD]
[TD]23564[/TD]
[TD]Yellow[/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]2003[/TD]
[TD]Pontiac[/TD]
[TD]Vibe[/TD]
[TD]Car[/TD]
[TD]PT3225ME-RL[/TD]
[TD]21547[/TD]
[TD]Rear Left[/TD]
[TD]23564[/TD]
[TD]Yellow[/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]2004[/TD]
[TD]Pontiac[/TD]
[TD]Vibe[/TD]
[TD]Car[/TD]
[TD]PT3225ME-RL[/TD]
[TD]21547[/TD]
[TD]Rear Left[/TD]
[TD]23564[/TD]
[TD]Yellow[/TD]
[/TR]
[/TABLE]

Em cần save mổi PartNumber...i.e...GM2007MA-FL ra từng workbook dùng VBA.

Cám ơn anh chị

Trinh

Quang_Hải · 1/11/14

mccdgxch đã viết:
Chào anh chị,

em có một worksheet nầy cần anh chị giúp đở.

[TABLE="width: 500"]
[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Year[/TD]
[TD]Make[/TD]
[TD]Model[/TD]
[TD]VehicleType[/TD]
[TD]PartNumber[/TD]
[TD]PartType[/TD]
[TD]Position[/TD]
[TD]OEM[/TD]
[TD]Color[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]1990[/TD]
[TD]Chevrolet[/TD]
[TD]Cobalt[/TD]
[TD]Car[/TD]
[TD]GM2007MA-FL[/TD]
[TD]11315[/TD]
[TD]Front Left[/TD]
[TD]22722[/TD]
[TD]Blue[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]1991[/TD]
[TD]Chevrolet[/TD]
[TD]Cobalt[/TD]
[TD]Car[/TD]
[TD]GM2007MA-FL[/TD]
[TD]11315[/TD]
[TD]Front Left[/TD]
[TD]22722[/TD]
[TD]Blue[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]1992[/TD]
[TD]Chevrolet[/TD]
[TD]Cobalt[/TD]
[TD]Car[/TD]
[TD]GM2007MA-FL[/TD]
[TD]11315[/TD]
[TD]Front Left[/TD]
[TD]22722[/TD]
[TD]Blue[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]2002[/TD]
[TD]Pontiac[/TD]
[TD]Vibe[/TD]
[TD]Car[/TD]
[TD]PT3225ME-RL[/TD]
[TD]21547[/TD]
[TD]Rear Left[/TD]
[TD]23564[/TD]
[TD]Yellow[/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]2001[/TD]
[TD]Pontiac[/TD]
[TD]Vibe[/TD]
[TD]Car[/TD]
[TD]PT3225ME-RL[/TD]
[TD]21547[/TD]
[TD]Rear Left[/TD]
[TD]23564[/TD]
[TD]Yellow[/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]2003[/TD]
[TD]Pontiac[/TD]
[TD]Vibe[/TD]
[TD]Car[/TD]
[TD]PT3225ME-RL[/TD]
[TD]21547[/TD]
[TD]Rear Left[/TD]
[TD]23564[/TD]
[TD]Yellow[/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]2004[/TD]
[TD]Pontiac[/TD]
[TD]Vibe[/TD]
[TD]Car[/TD]
[TD]PT3225ME-RL[/TD]
[TD]21547[/TD]
[TD]Rear Left[/TD]
[TD]23564[/TD]
[TD]Yellow[/TD]
[/TR]
[/TABLE]

Em cần save mổi PartNumber...i.e...GM2007MA-FL ra từng workbook dùng VBA.

Cám ơn anh chị

Trinh

Có sẵn 1 Sub này bạn thử xài coi được không

PHP:

Sub Tach_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([E2], [E65536].End(3)).Value
Set Sdata = Range([A1], [A65536].End(3)).Resize(, 9)
For i = 1 To UBound(Data)
   If Data(i, 1) <> "" Then Dic.Item(Data(i, 1)) = ""
Next
For Each Ma In Dic.keys
   With Sdata
      .AutoFilter 5, Ma
      .SpecialCells(12).Copy
      Workbooks.Add
      With ActiveWorkbook
         .ActiveSheet.Name = Ma
         .ActiveSheet.[A1].PasteSpecial 1
         .ActiveSheet.[A:I].Columns.AutoFit
         .SaveAs ThisWorkbook.Path & "\" & Ma, 51
         .Close True
      End With
      .AutoFilter
   End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

mccdgxch · 1/11/14

Thanks

Em cám ơn anh QuangHai thật nhiều.

Chúc anh sức khỏe

mccdgxch · 1/11/14

Chào anh Quân,

Em có một worksheet nửa cần tách file...hơi phức tạp chút...nếu dùng VBA code ở trên thì em nên sửa code như thế nào cho thích hợp? Mong anh giúp em.

Cám ơn anh

Quang_Hải · 1/11/14

mccdgxch đã viết:
Chào anh Quân,

Em có một worksheet nửa cần tách file...hơi phức tạp chút...nếu dùng VBA code ở trên thì em nên sửa code như thế nào cho thích hợp? Mong anh giúp em.

Cám ơn anh

Hỏng biết anh Quân là anh nào nhưng thôi cũng ké vô cái.
Bạn sửa code cũng đúng 99% rồi, thiếu tí xíu nữa là được rồi.

PHP:

Sub Tach_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([B2], [B65536].End(3)).Value
Set Sdata = Range([B1], [B65536].End(3)).Resize(, 17)
For i = 1 To UBound(Data)
   If Data(i, 1) <> "" Then Dic.Item(Data(i, 1)) = ""
Next
For Each Ma In Dic.keys
   With Sdata
      .AutoFilter 1, Ma
      .SpecialCells(12).Copy
      Workbooks.Add
      With ActiveWorkbook
         .ActiveSheet.Name = Ma
         .ActiveSheet.[A1].PasteSpecial 1
         .ActiveSheet.[A:R].Columns.AutoFit
         .SaveAs ThisWorkbook.Path & "\" & Ma, 51
         .Close True
      End With
      .AutoFilter
   End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

mccdgxch · 3/11/14

Hi anh QuangHai,

cho em hỏi, nếu em muốn save file nầy dưới dạng .cvs file thi chỉnh code như thế nào. Mong anh giúp em.

Thanks

Trinh

phuthuy_dt · 21/8/15

quanghai1969 đã viết:

Hỏng biết anh Quân là anh nào nhưng thôi cũng ké vô cái.
Bạn sửa code cũng đúng 99% rồi, thiếu tí xíu nữa là được rồi.

PHP:

Sub Tach_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([B2], [B65536].End(3)).Value
Set Sdata = Range([B1], [B65536].End(3)).Resize(, 17)
For i = 1 To UBound(Data)
   If Data(i, 1) <> "" Then Dic.Item(Data(i, 1)) = ""
Next
For Each Ma In Dic.keys
   With Sdata
      .AutoFilter 1, Ma
      .SpecialCells(12).Copy
      Workbooks.Add
      With ActiveWorkbook
         .ActiveSheet.Name = Ma
         .ActiveSheet.[A1].PasteSpecial 1
         .ActiveSheet.[A:R].Columns.AutoFit
         .SaveAs ThisWorkbook.Path & "\" & Ma, 51
         .Close True
      End With
      .AutoFilter
   End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Hi anh,
em muốn hỏi là nếu em muốn tách ra workbook mới nhưng em muốn đặt tên theo ngày hôm nay, vì ngày nào em cũng tách thì code viết ntn hả anh?

seikoqn · 21/8/15

phuthuy_dt đã viết:
Hi anh,
em muốn hỏi là nếu em muốn tách ra workbook mới nhưng em muốn đặt tên theo ngày hôm nay, vì ngày nào em cũng tách thì code viết ntn hả anh?

Bạn nên đưa File lên và nêu yêu cầu cụ thể trong File chứ? Bạn hỏi chung chung vậy ai biết trả lời thế nào????

làm sao tách ra và save từng workbook theo PartNumber dùng VBA

mccdgxch

Thành viên mới

Quang_Hải

Thành viên gạo cội

mccdgxch

Thành viên mới

mccdgxch

Thành viên mới

File đính kèm

Quang_Hải

Thành viên gạo cội

mccdgxch

Thành viên mới

phuthuy_dt

Thành viên mới

seikoqn

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