Xóa Styles - Excel 2010!

[PhanTuHuong]

Đang dùng cách tà đạo như sau:
1/ Lấy 1 file Styles.xlm chuẩn, khi tạo file thì lưu riêng.
2/ Trong quá trình làm việc nếu có copy sh nếu tạo ra style rác thì làm tiếp.
3/ Đổi đuôi file thành .zip
4/Thay thế file chuẩn vào.
5/ Thay lại đuôi.
Công đoạn đó cũng OK, sẽ vận dụng code của anh Siwtom xóa Style.xlm và thay thế.
Còn dùng code sau để xác định các Style BuiltIn và xóa nhưng kg dc.

Sub ListStyles()
Dim objStyle As Excel.Style
For Each objStyle In ActiveWorkbook.Styles
  On Error Resume Next
  If Not objStyle.BuiltIn Then
    MsgBox objStyle.Name
    objStyle.Delete
  End If
  On Error GoTo 0
Next objStyle
End Sub

Cám ơn anh Siwtom và NDU nhiều.

Các Style rác bị khóa, đầu tiên phải mở khóa rồi mới xóa. Anh xem đoạn code ở trên nhé!

 

[giang5288]

Các Style rác bị khóa, đầu tiên phải mở khóa rồi mới xóa. Anh xem đoạn code ở trên nhé!

bạn oi mình dang lam dự toán mà nó bị như vậy mình đọc mà chưa hiểu cách của mấy bạn, bạn chỉ rõ giùm mình được không?
cho mình xin SĐT có gì mình alo xin chỉ giùm? mai mình phải nộp bài.

 

[dhxdk43]

Private Declare Function ShellExecuteEx Lib "shell32.dll" (ByRef lpExecInfo As SHELLEXECUTEINFO) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long

Bác nào chuyển hộ mình mấy code trên cho win 64bit với.
Mình không biết gì về cái này.

 

[tranngochoan]

Toàn bộ giải thuật chỉ là đổi đuôi file xlsx hoặc xlsm thành .RAR. Xong giải nén rồi xử lý chuổi nằm bên trong file styles.xml thôi mà

Kính gửi Các Bác
Em đang vướng không lưu được định dạng, Và không xóa được style rác, Mong các bác giúp đỡ cho em với, Cuối năm cần việc mà chưa giải quyết được, (File em gửi lên bên dưới). Tha thiết mong các Bác giúp đỡ

 

[echo07]

Đoạn code sau cũng xóa Style rác, nhưng cũng chưa hoàn toàn triệt để:

Sub StyleKill()
        Dim CellStyle As Style
        On Error Resume Next
        Application.ScreenUpdating = False
        For Each CellStyle In ActiveWorkbook.Styles
            If Not CellStyle.BuiltIn Then
                CellStyle.Locked = False    'Bỏ khóa nếu Style bị khóa
                CellStyle.Delete
            End If
        Next CellStyle
        Application.ScreenUpdating = True
        Set CellStyle = Nothing
End Sub

Quá nhanh, quá nguy hiểm ạ.

 

[tueyennhi]

Bác nào chuyển hộ mình mấy code trên cho win 64bit với.
Mình không biết gì về cái này.

Code này có trong file Del name and style của thầy ndu phải không bạn? Mình cũng đang không sử dụng được trên 64bit.

 

[sangnks]

Cải tiến tiếp code của anh siwtom đây (xác định BuiltIn ngay trong filt style.xml luôn)

Private Const rarApp = "winrar.exe"
Sub PrepareAndRun(ByVal Excel_File As String)
  Dim Params As String, filename As String, StartDir As String, ext As String
  Dim text As String, text2 As String, text3 As String
  Dim Arr, aBuiltInYes(), aBuiltInNo()
  Dim lBuiltInYes As Long, lBuiltInNo As Long, i As Long, start As Long, end_ As Long

  With CreateObject("Scripting.FileSystemObject")
    ext = .GetExtensionName(Excel_File)
    If ext <> "xlsm" And ext <> "xlsx" Then Exit Sub
    filename = .GetFile(Excel_File).Name
    StartDir = .GetFile(Excel_File).ParentFolder.Path
    Params = "x -apxl " & """" & Excel_File & """" & " xl\styles.xml"
    If RunAndStop(rarApp, Params, StartDir) Then
      With .OpenTextFile(StartDir & "\styles.xml")
        text = .ReadAll
        .Close
      End With
      .DeleteFile StartDir & "\styles.xml", True
      start = InStr(1, text, "<cellStyle name=")
      end_ = InStr(1, text, "</cellStyles>")
      text2 = Mid(text, start, end_ - 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
        text = Replace(text, text2, Join(aBuiltInYes, ""))
        .CreateTextFile(StartDir & "\styles.xml").Write text
        Params = "a -apxl " & """" & Excel_File & """" & " styles.xml"
        If RunAndStop(rarApp, Params, StartDir) Then
          .DeleteFile StartDir & "\styles.xml", True
          MsgBox "Da xoa xong " & lBuiltInNo & " styles rác"
        End If
      Else
        MsgBox "Không có styles rác nào"
      End If
    End If
  End With
End Sub

ThuNghi thử xem!
Tôi vừa chơi xong mấy file, thấy rất ngon lành: Xóa sạch không chừa 1 style rác nào
Trong file đính kèm tôi mới thiết kế cái UserForm nhưng chưa kịp viết code ---> ThuNghi làm tiếp nha ---> Xử lý biến mảng aBuiltInNo rồi cho vào ListBox là được rồi

Cám ơn. hay ạ.