Cách xóa Style rác trong Excel 2010

Cuối cùng cũng có người biết vận dụng. Cảm ơn Mạnh! Thì tôi mở topic đó nhằm mục đích này đây. Tại lúc đó mọi người không để ý thôi (chỉ tôi với anh Rô "diễn" qua lại cũng... chán)

Nói chung là bất cứ thứ gì có liên quan đến việc xử lý file xml đều có thể suy nghĩ được
Thậm chí tôi còn có ý định xa hơn: Viết Ribbon trực tiếp trong VBA luôn. Mạnh thử nghiên cứu xem

----------------------------------

(Thời gian này tôi bận quá, chỉ lên GPE xem sơ qua chứ không kịp làm được gì cả)

Thua ....................... Mạnh có xài macOS đâu mà biết code két sao .............. e rằng code trên macOS trên GPE này rất hiếm người biết đó, có thể có nhưng hiến lắm

Sub StyleKill() Dim styT As Style Dim intRet As Integer On Error Resume Next For Each styT In ActiveWorkbook.Styles If Not styT.BuiltIn Then If styT.Name <> "1" Then styT.Delete End If Next styT

End Sub​

hoặc core chạy VBA cũng được vì em dùng sub này

Sub StyleKill() Dim styT As Style Dim intRet As Integer On Error Resume Next For Each styT In ActiveWorkbook.Styles If Not styT.BuiltIn Then If styT.Name <> "1" Then styT.Delete End If Next styT

End Sub​

thì có một số style ko cách nào xóa được, kể cả xóa bằng tay. File nó đây, anh xem giúp em với, em cám ơn.

Ý em là nếu em dùng Clear Styles Office Excel Ver2.rar này của anh chạy em xóa sạch được hết nhưng khi dùng trên macOS thì do đây là file exe nên em không chạy được nên em phải dùng code vba em post ở trên để xóa nhưng code này lại không xóa được hết và có một số style xóa bằng tay cũng ko xóa được nên em muốn hỏi anh xem anh có code vba nào xóa được hết không. Em cám ơn.

Minh đã dùng Clear Styles Office Excel Ver2.rar để xóa styles cho file excel và sau khi chạy xong thì nó thành file.xlsx dạng zip ( như file đính kèm) . giờ làm sao để khôi phục lại file ecxel như ban đầu ak ,

Xuất phát từ topic Add-Ins Tạo Menu RibbonTiếng Việt Có Dấu Cho Office Link

http://www.giaiphapexcel.com/forum/showthread.php?118088-Add-Ins-Tạo-Menu-RibbonTiếng-Việt-Có-Dấu-Cho-Office

Mạnh có nghiên cứu lại một loạt bài của Bạn doveandrose và Anh ndu96081631

Link

http://www.giaiphapexcel.com/forum/showthread.php?108310-V%E1%BB%8Dc-ch%C6%A1i-v%E1%BB%9Bi-nh%E1%BB%AFng-thu%E1%BA%ADt-to%C3%A1n-n%C3%A9n-v%C3%A0-gi%E1%BA%A3i-n%C3%A9n-file

Sau khi nghiên cứu thuật toán winrar từ loạt bài link trên để phục phụ cho mục đích Viết Add-Ins Ribbon

thì mình bất chợt nhận ra rằng nó có liên quan và xử lý tốt cho styles mà doveandrose và Anh ndu96081631 đã viết ở topic đó ....vậy Mình mượn hai Hàm của doveandrose và Anh ndu96081631

Và viết thêm 1 hàm nữa ngắn gọn để xử lý styles rác thấy hiệu quả Úp lên cho Bạn nào cần thì tải về mà xài ....chạy tốt trên mọi Win32 & 64 bit

Nếu Bạn doveandrose và Anh ndu96081631 .... Có ghé qua thì Chấm điểm dùm đồ đệ theo hai thầy học thuật toán Winrar Nộp bài liệu có được 5 điểm chăng ....

Xin cảm ơn 2 thầy với loạt bài

Vọc chơi với những thuật toán nén và giải nén file

Code Của Bạn doveandrose

Private Function ClearStyleXML(ByVal xmlFile As String) As Boolean Dim doc As Object, xNode, n As Long ''// Copy Form doveandrose - www.giaiphapexcel.com Set doc = CreateObject("Microsoft.XMLDOM") doc.Load xmlFile For Each xNode In doc.SelectNodes("/styleSheet/cellStyles/cellStyle") If TypeName(xNode.Attributes.getNamedItem("builtinId")) = "Nothing" Then xNode.ParentNode.RemoveChild xNode n = n + 1 End If Next If n > 0 Then UniMsgbox "Da xoa xong " & n & " styles rác" doc.Save xmlFile ClearStyleXML = True Else ClearStyleXML = False UniMsgbox "Không có styles rác nào" End If Set doc = Nothing End Function

Code Của Anh ndu96081631

Private Function ClearStylesFromXML(ByVal xmlFile As String) As Boolean Dim Params As String, FileName As String, StartDir As String, Ext As String Dim text1 As String, text2 As String, text3 As String Dim Arr, aBuiltInYes(), aBuiltInNo() ''// Copy Form ndu96081631 - www.giaiphapexcel.com Dim lBuiltInYes As Long, lBuiltInNo As Long, i As Long, lPos_Start As Long, lPos_End As Long Dim Fso As Object Set Fso = CreateObject("Scripting.FileSystemObject") 'On Error Resume Next With Fso If Not .FileExists(xmlFile) Then Exit Function If .GetFile(xmlFile).Name <> "styles.xml" Then Exit Function With .OpenTextFile(xmlFile) text1 = .ReadAll .Close End With lPos_Start = InStr(1, text1, "<cellStyle name=") lPos_End = InStr(1, text1, "</cellStyles>") text2 = Mid(text1, lPos_Start, lPos_End - lPos_Start) text3 = Replace(text2, "/><", "/>" & vbLf & "<") Arr = Split(text3, vbLf) For i = LBound(Arr) To UBound(Arr) If InStr(1, Arr(i), "builtinId") Then lBuiltInYes = lBuiltInYes + 1 ReDim Preserve aBuiltInYes(1 To lBuiltInYes) aBuiltInYes(lBuiltInYes) = Arr(i) Else lBuiltInNo = lBuiltInNo + 1 ReDim Preserve aBuiltInNo(1 To lBuiltInNo) aBuiltInNo(lBuiltInNo) = Arr(i) End If Next If lBuiltInNo Then text1 = Replace(text1, text2, Join(aBuiltInYes, "")) .CreateTextFile(xmlFile, True).Write text1 MsgBox "Da xoa xong " & lBuiltInNo & " styles rác" ClearStylesFromXML = True Else MsgBox "Không có styles rác nào" ClearStylesFromXML = False End If End With Set Fso = Nothing End Function

Code Kiều Mạnh

Private Sub Deletestyles(ByVal FileExcel As String) Dim Fso As Object, ObjShell As Object, Ext As String Dim FileName_Path, ZipFile, xml As String ''// Coded by Kieu Manh - www.giaiphapexcel.com ZipFile = FileExcel & ".zip" Set ObjShell = CreateObject("Shell.Application") Set Fso = CreateObject("Scripting.FileSystemObject") FileName_Path = Fso.GetParentFolderName(FileExcel) xml = FileName_Path & "\styles.xml" Ext = Fso.GetExtensionName(FileExcel) If (UCase(Ext) <> "XLSX") And (UCase(Ext) <> "XLSM") And (UCase(Ext) <> "XLAM") Then Exit Sub If Fso.FileExists(FileExcel) Then Fso.MoveFile FileExcel, FileExcel & ".zip" ObjShell.Namespace(FileName_Path).movehere ObjShell.Namespace(ZipFile).items.Item("xl\styles.xml") Do While ObjShell.Namespace(ZipFile & "\xl\") Is Nothing Application.Wait (Now + 0.000005) Loop Rem If ClearStyleXML(xml) Then ''//Ok 1 If ClearStylesFromXML(xml) Then ''//Ok 2 ....Thuy thich xai Ham tren hay duoi cung OK ObjShell.Namespace(ZipFile & "\xl\").movehere ObjShell.Namespace(FileName_Path).items.Item("styles.xml") Do While ObjShell.Namespace(ZipFile & "\xl\") Is Nothing Application.Wait (Now + 0.000005) Loop Else ObjShell.Namespace(ZipFile & "\xl\").movehere ObjShell.Namespace(FileName_Path).items.Item("styles.xml") Do Until Not Fso.FileExists(xml) Application.Wait (Now + 0.000005) Loop Fso.MoveFile FileExcel & ".zip", FileExcel Exit Sub End If Do Until Not Fso.FileExists(xml) Application.Wait (Now + 0.000005) Loop Fso.MoveFile FileExcel & ".zip", FileExcel UniMsgbox "done" End If Set ObjShell = Nothing Set Fso = Nothing End Sub

Giải nén ra trong Folder có: 1/ 1 Filestyles.rar là file có nhiều styles rác mà test

2/ Trong Folder có 1 file ClearStyles Office Excel.exe rành cho Bạn nào chưa biết bật Mắt Rô thì chạy file đó cho nó gọn chức năng như file ClearStyles Office Excel.xlsm

3/ Mình Bổ sung thêm xử lý 2 Loại File Excel nữa là 5 Loại File ::

*.xls; *.xlsx;*.xlsm;*.xlsb;*.xlam

Tải File

ClearStyles Office Excel_Ver2.rar

Bài đã được tự động gộp: 18/9/19

ca nha oi giup em voi, em khong the luu duoc file sau khi sua va luu lai lai mat het dinh dang a, em cam on,

ca nha oi giup em voi, em khong the luu duoc file sau khi sua va luu lai lai mat het dinh dang a, em cam on,

2/ Bạn nên viết bài đúng mục (box) và đúng chủ đề của topic. Có nghĩa là bạn hỏi về "lưu File bị mất định dạng" trong khi đó chủ đề của Topic này là "Xóa styles rác trong Excel" (sai với chủ đề của Topic) có thể sẽ vi phạm nội quy.

Xuất phát từ topic Add-Ins Tạo Menu RibbonTiếng Việt Có Dấu Cho Office Link

http://www.giaiphapexcel.com/forum/showthread.php?118088-Add-Ins-Tạo-Menu-RibbonTiếng-Việt-Có-Dấu-Cho-Office

Mạnh có nghiên cứu lại một loạt bài của Bạn doveandrose và Anh ndu96081631

Link

http://www.giaiphapexcel.com/forum/showthread.php?108310-V%E1%BB%8Dc-ch%C6%A1i-v%E1%BB%9Bi-nh%E1%BB%AFng-thu%E1%BA%ADt-to%C3%A1n-n%C3%A9n-v%C3%A0-gi%E1%BA%A3i-n%C3%A9n-file

Sau khi nghiên cứu thuật toán winrar từ loạt bài link trên để phục phụ cho mục đích Viết Add-Ins Ribbon

thì mình bất chợt nhận ra rằng nó có liên quan và xử lý tốt cho styles mà doveandrose và Anh ndu96081631 đã viết ở topic đó ....vậy Mình mượn hai Hàm của doveandrose và Anh ndu96081631

Và viết thêm 1 hàm nữa ngắn gọn để xử lý styles rác thấy hiệu quả Úp lên cho Bạn nào cần thì tải về mà xài ....chạy tốt trên mọi Win32 & 64 bit

Nếu Bạn doveandrose và Anh ndu96081631 .... Có ghé qua thì Chấm điểm dùm đồ đệ theo hai thầy học thuật toán Winrar Nộp bài liệu có được 5 điểm chăng ....

Xin cảm ơn 2 thầy với loạt bài

Vọc chơi với những thuật toán nén và giải nén file

Code Của Bạn doveandrose

Private Function ClearStyleXML(ByVal xmlFile As String) As Boolean Dim doc As Object, xNode, n As Long ''// Copy Form doveandrose - www.giaiphapexcel.com Set doc = CreateObject("Microsoft.XMLDOM") doc.Load xmlFile For Each xNode In doc.SelectNodes("/styleSheet/cellStyles/cellStyle") If TypeName(xNode.Attributes.getNamedItem("builtinId")) = "Nothing" Then xNode.ParentNode.RemoveChild xNode n = n + 1 End If Next If n > 0 Then UniMsgbox "Da xoa xong " & n & " styles rác" doc.Save xmlFile ClearStyleXML = True Else ClearStyleXML = False UniMsgbox "Không có styles rác nào" End If Set doc = Nothing End Function

Code Của Anh ndu96081631

Private Function ClearStylesFromXML(ByVal xmlFile As String) As Boolean Dim Params As String, FileName As String, StartDir As String, Ext As String Dim text1 As String, text2 As String, text3 As String Dim Arr, aBuiltInYes(), aBuiltInNo() ''// Copy Form ndu96081631 - www.giaiphapexcel.com Dim lBuiltInYes As Long, lBuiltInNo As Long, i As Long, lPos_Start As Long, lPos_End As Long Dim Fso As Object Set Fso = CreateObject("Scripting.FileSystemObject") 'On Error Resume Next With Fso If Not .FileExists(xmlFile) Then Exit Function If .GetFile(xmlFile).Name <> "styles.xml" Then Exit Function With .OpenTextFile(xmlFile) text1 = .ReadAll .Close End With lPos_Start = InStr(1, text1, "<cellStyle name=") lPos_End = InStr(1, text1, "</cellStyles>") text2 = Mid(text1, lPos_Start, lPos_End - lPos_Start) text3 = Replace(text2, "/><", "/>" & vbLf & "<") Arr = Split(text3, vbLf) For i = LBound(Arr) To UBound(Arr) If InStr(1, Arr(i), "builtinId") Then lBuiltInYes = lBuiltInYes + 1 ReDim Preserve aBuiltInYes(1 To lBuiltInYes) aBuiltInYes(lBuiltInYes) = Arr(i) Else lBuiltInNo = lBuiltInNo + 1 ReDim Preserve aBuiltInNo(1 To lBuiltInNo) aBuiltInNo(lBuiltInNo) = Arr(i) End If Next If lBuiltInNo Then text1 = Replace(text1, text2, Join(aBuiltInYes, "")) .CreateTextFile(xmlFile, True).Write text1 MsgBox "Da xoa xong " & lBuiltInNo & " styles rác" ClearStylesFromXML = True Else MsgBox "Không có styles rác nào" ClearStylesFromXML = False End If End With Set Fso = Nothing End Function

Code Kiều Mạnh

Private Sub Deletestyles(ByVal FileExcel As String) Dim Fso As Object, ObjShell As Object, Ext As String Dim FileName_Path, ZipFile, xml As String ''// Coded by Kieu Manh - www.giaiphapexcel.com ZipFile = FileExcel & ".zip" Set ObjShell = CreateObject("Shell.Application") Set Fso = CreateObject("Scripting.FileSystemObject") FileName_Path = Fso.GetParentFolderName(FileExcel) xml = FileName_Path & "\styles.xml" Ext = Fso.GetExtensionName(FileExcel) If (UCase(Ext) <> "XLSX") And (UCase(Ext) <> "XLSM") And (UCase(Ext) <> "XLAM") Then Exit Sub If Fso.FileExists(FileExcel) Then Fso.MoveFile FileExcel, FileExcel & ".zip" ObjShell.Namespace(FileName_Path).movehere ObjShell.Namespace(ZipFile).items.Item("xl\styles.xml") Do While ObjShell.Namespace(ZipFile & "\xl\") Is Nothing Application.Wait (Now + 0.000005) Loop Rem If ClearStyleXML(xml) Then ''//Ok 1 If ClearStylesFromXML(xml) Then ''//Ok 2 ....Thuy thich xai Ham tren hay duoi cung OK ObjShell.Namespace(ZipFile & "\xl\").movehere ObjShell.Namespace(FileName_Path).items.Item("styles.xml") Do While ObjShell.Namespace(ZipFile & "\xl\") Is Nothing Application.Wait (Now + 0.000005) Loop Else ObjShell.Namespace(ZipFile & "\xl\").movehere ObjShell.Namespace(FileName_Path).items.Item("styles.xml") Do Until Not Fso.FileExists(xml) Application.Wait (Now + 0.000005) Loop Fso.MoveFile FileExcel & ".zip", FileExcel Exit Sub End If Do Until Not Fso.FileExists(xml) Application.Wait (Now + 0.000005) Loop Fso.MoveFile FileExcel & ".zip", FileExcel UniMsgbox "done" End If Set ObjShell = Nothing Set Fso = Nothing End Sub

Giải nén ra trong Folder có: 1/ 1 Filestyles.rar là file có nhiều styles rác mà test

2/ Trong Folder có 1 file ClearStyles Office Excel.exe rành cho Bạn nào chưa biết bật Mắt Rô thì chạy file đó cho nó gọn chức năng như file ClearStyles Office Excel.xlsm

3/ Mình Bổ sung thêm xử lý 2 Loại File Excel nữa là 5 Loại File ::

*.xls; *.xlsx;*.xlsm;*.xlsb;*.xlam

Tải File

ClearStyles Office Excel_Ver2.rar

Anh cho em xin code xóa Style rác để em cho vào cái Add-ins tổng hợp của em nhé ạ (em đã mạo muộn cho vào rồi ạ ). Em chuẩn bị dạy học nên làm cái Add-ins này tặng các học viên, em không biết gì về VBA mấy, chủ yếu đi sưu tầm các code anh chị chia sẻ tổng hợp lại thôi ạ. Hôm vừa rồi xem được clip hướng dẫn làm Ribbon menu của anh Lê Duyệt nên đã làm luôn. Em hy vọng Add-ins sẽ giúp cho học viên cũng như người đi làm (nghề QS xây dựng) nâng cao năng suất công việc lên ạ.

Link clip giới thiệu Add-ins:

Úp cái Add-ins đó lên cho coi 1 tí đi ... úp cái Video thấy ngại lắm

Link download: https://xaydungthuchanh.vn/downloadtailieu/XDTH_Ribbon Menu_1.0.rar

Bài đã được tự động gộp: 7/6/20

Xuất phát từ topic Add-Ins Tạo Menu RibbonTiếng Việt Có Dấu Cho Office Link

http://www.giaiphapexcel.com/forum/...s-Tạo-Menu-RibbonTiếng-Việt-Có-Dấu-Cho-Office

Mạnh có nghiên cứu lại một loạt bài của Bạn doveandrose và Anh ndu96081631 Link

thì mình bất chợt nhận ra rằng nó có liên quan và xử lý tốt cho styles mà doveandrose và Anh ndu96081631 đã viết ở topic đó ....vậy Mình mượn hai Hàm của doveandrose và Anh ndu96081631 Và viết thêm 1 hàm nữa ngắn gọn để xử lý styles rác thấy hiệu quả Úp lên cho Bạn nào cần thì tải về mà xài ....chạy tốt trên mọi Win32 & 64 bit

Code Của Bạn doveandrose

Private Function ClearStyleXML(ByVal xmlFile As String) As Boolean Dim doc As Object, xNode, n As Long ''// Copy Form doveandrose - www.giaiphapexcel.com Set doc = CreateObject("Microsoft.XMLDOM") doc.Load xmlFile For Each xNode In doc.SelectNodes("/styleSheet/cellStyles/cellStyle") If TypeName(xNode.Attributes.getNamedItem("builtinId")) = "Nothing" Then xNode.ParentNode.RemoveChild xNode n = n + 1 End If Next If n > 0 Then UniMsgbox "Da xoa xong " & n & " styles rác" doc.Save xmlFile ClearStyleXML = True Else ClearStyleXML = False UniMsgbox "Không có styles rác nào" End If Set doc = Nothing End Function

Private Function ClearStylesFromXML(ByVal xmlFile As String) As Boolean Dim Params As String, FileName As String, StartDir As String, Ext As String Dim text1 As String, text2 As String, text3 As String Dim Arr, aBuiltInYes(), aBuiltInNo() ''// Copy Form ndu96081631 - www.giaiphapexcel.com Dim lBuiltInYes As Long, lBuiltInNo As Long, i As Long, lPos_Start As Long, lPos_End As Long Dim Fso As Object Set Fso = CreateObject("Scripting.FileSystemObject") 'On Error Resume Next With Fso If Not .FileExists(xmlFile) Then Exit Function If .GetFile(xmlFile).Name <> "styles.xml" Then Exit Function With .OpenTextFile(xmlFile) text1 = .ReadAll .Close End With lPos_Start = InStr(1, text1, "<cellStyle name=") lPos_End = InStr(1, text1, "</cellStyles>") text2 = Mid(text1, lPos_Start, lPos_End - lPos_Start) text3 = Replace(text2, "/><", "/>" & vbLf & "<") Arr = Split(text3, vbLf) For i = LBound(Arr) To UBound(Arr) If InStr(1, Arr(i), "builtinId") Then lBuiltInYes = lBuiltInYes + 1 ReDim Preserve aBuiltInYes(1 To lBuiltInYes) aBuiltInYes(lBuiltInYes) = Arr(i) Else lBuiltInNo = lBuiltInNo + 1 ReDim Preserve aBuiltInNo(1 To lBuiltInNo) aBuiltInNo(lBuiltInNo) = Arr(i) End If Next If lBuiltInNo Then text1 = Replace(text1, text2, Join(aBuiltInYes, "")) .CreateTextFile(xmlFile, True).Write text1 MsgBox "Da xoa xong " & lBuiltInNo & " styles rác" ClearStylesFromXML = True Else MsgBox "Không có styles rác nào" ClearStylesFromXML = False End If End With Set Fso = Nothing End Function

Private Sub Deletestyles(ByVal FileExcel As String) Dim Fso As Object, ObjShell As Object, Ext As String Dim FileName_Path, ZipFile, xml As String ''// Coded by Kieu Manh - www.giaiphapexcel.com ZipFile = FileExcel & ".zip" Set ObjShell = CreateObject("Shell.Application") Set Fso = CreateObject("Scripting.FileSystemObject") FileName_Path = Fso.GetParentFolderName(FileExcel) xml = FileName_Path & "\styles.xml" Ext = Fso.GetExtensionName(FileExcel) If (UCase(Ext) <> "XLSX") And (UCase(Ext) <> "XLSM") And (UCase(Ext) <> "XLAM") Then Exit Sub If Fso.FileExists(FileExcel) Then Fso.MoveFile FileExcel, FileExcel & ".zip" ObjShell.Namespace(FileName_Path).movehere ObjShell.Namespace(ZipFile).items.Item("xl\styles.xml") Do While ObjShell.Namespace(ZipFile & "\xl\") Is Nothing Application.Wait (Now + 0.000005) Loop Rem If ClearStyleXML(xml) Then ''//Ok 1 If ClearStylesFromXML(xml) Then ''//Ok 2 ....Thuy thich xai Ham tren hay duoi cung OK ObjShell.Namespace(ZipFile & "\xl\").movehere ObjShell.Namespace(FileName_Path).items.Item("styles.xml") Do While ObjShell.Namespace(ZipFile & "\xl\") Is Nothing Application.Wait (Now + 0.000005) Loop Else ObjShell.Namespace(ZipFile & "\xl\").movehere ObjShell.Namespace(FileName_Path).items.Item("styles.xml") Do Until Not Fso.FileExists(xml) Application.Wait (Now + 0.000005) Loop Fso.MoveFile FileExcel & ".zip", FileExcel Exit Sub End If Do Until Not Fso.FileExists(xml) Application.Wait (Now + 0.000005) Loop Fso.MoveFile FileExcel & ".zip", FileExcel UniMsgbox "done" End If Set ObjShell = Nothing Set Fso = Nothing End Sub

2/ Trong Folder có 1 file ClearStyles Office Excel.exe rành cho Bạn nào chưa biết bật Mắt Rô thì chạy file đó cho nó gọn chức năng như file ClearStyles Office Excel.xlsm 3/ Mình Bổ sung thêm xử lý 2 Loại File Excel nữa là 5 Loại File ::

*.xls; *.xlsx;*.xlsm;*.xlsb;*.xlam

Tải File