Xóa styles rác trong Excel

Kiều Mạnh · 16/9/16

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
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

Mã:

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

Mã:

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

Mã:

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

Kiều Mạnh · 8/6/20

vuongdanhthang đã viết:
Cái video là hướng dẫn sử dụng Add-ins, hơi dài thật vì em sau này phục vụ học viên là sinh viên nên làm rất chi tiết. Em có để link tải ở phần mô tả đó anh. Các anh đừng ném đá em nhé, em có biết code cách gì đâu, toàn học lỏm đi cóp nhặt các anh chia sẻ về tổng hợp lại thôi à.
Em up lại lên đây:
Link download: https://xaydungthuchanh.vn/downloadtailieu/XDTH_Ribbon Menu_1.0.rar

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

Em cũng vừa mới viết xong bài viết hướng dẫn sử dụng, anh chị có thể xem bài viết sẽ nhanh hơn xem video ạ.

Add in Excel XDTH cho dân văn phòng, công cụ không thể thiếu đối với QS - xaydungthuchanh.vn

Add in Excel XDTH dùng kẻ bảng, tính tổng, xử lý dữ liệu xuất từ CAD nhanh chóng hiệu quả... công cụ tuyệt vời danh cho kỹ sư QS

xaydungthuchanh.vn

Hay đó ... cái khó khăn và dào cản lớn nhất của mỗi con người là ko dám nhìn nhận cái mặt trái và góc khuất của chính mình hay nổi khùng khi ai đó phê phán hay phản biện ...

hãy cố giắng lên vượt lên tất cả và chứng minh rằng code tui viết ra là ko có của ném đá hay chê bai này nọ ... đó mới tạo nên đẳng cấp vượt thời gian

vuongdanhthang · 8/6/20

Kiều Mạnh đã viết:
Hay đó ... cái khó khăn và dào cản lớn nhất của mỗi con người là ko dám nhìn nhận cái mặt trái và góc khuất của chính mình hay nổi khùng khi ai đó phê phán hay phản biện ...

hãy cố giắng lên vượt lên tất cả và chứng minh rằng code tui viết ra là ko có của ném đá hay chê bai này nọ ... đó mới tạo nên đẳng cấp vượt thời gian

Em cảm ơn anh đã động viên em ạ^^

dinhduy · 22/3/22

Kiều Mạnh đã viết:
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

Mã:

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

Mã:

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

Mã:

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

Không biết Bác còn nghiên cứu vấn đề này không ah
Em chạy thử có 2 trường hợp cho 2 File khác nhau cho kết quả như sau:
- Tập tin 01.xlsb ClearStyles thì thành công (vẫn là 01.xlsb), chuyển qua 01.xlsm không hề bị lỗi gì hết
- Tập tin 02.xlsb ClearStyles thì thành công (vẫn là 01.xlsb - bị lỗi mất toàn bộ định dạng), nhưng khi chuyển qua 02.xlsm (File gốc 02.xlsb) ClearStyles không hề bị lỗi gì hết (vẫn là 02.xlsm), 02.xlsm đã ClearStyles chuyển qua lại 02.xlsb thì vẫn bị lỗi mất toàn bộ định dạng
Em cám ơn !

big_goat · 9/10/24

Kiều Mạnh đã viết:
Thì code ở bài #1 đó copy về cứ vậy mà xử lý .... Trong File *.exe code cũng như vây mà tại mình làm vậy cho bạn nào chưa biết Enable Macro sử dụng cho nó thuận tiện thbạn

Bạn cho mình hỏi làm sao để build thành file exe được vậy? mình có dùng phần mềm nào không?

kampria_328 · 9/10/24

bác Mạnh có kinh nghiệm viết xll sdk c/c++, share cho ae chút coi

Xóa styles rác trong Excel

Kiều Mạnh

I don't program, I beat code into submission!!!

File đính kèm

Kiều Mạnh

I don't program, I beat code into submission!!!

Add in Excel XDTH cho dân văn phòng, công cụ không thể thiếu đối với QS - xaydungthuchanh.vn

vuongdanhthang

Thành viên mới

dinhduy

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

big_goat

Thành viên mới

kampria_328

Thành viên mới

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

Đếm ngược thời gian

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