Benutzerdef. Formate auflisten/ löschen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

[Styles] cellStyle.name| ??aretli Hücre ?yi ?zlenen Köprü 20 % - Akzent1 20 % - Akzent2 20 % - Akz ent3 20 % - Akzent4 20 % - Akzent5 20 % - Akzent6 40 % - Akzent1 40 % - Akzent2 40 % - Akzent3 40 % - Akzent4 40 % - Akzent5 40 % - Akzent6 60 % - Akzent1 60 % - Akzent2 60 % - Akzent3 60 % - Akze nt4 60 % - Akzent5 60 % - Akzent6 Aç?klama Metni Açıklama Metni Akzent1 Akzent2 Akzent3 Akzent4 Ak zent5 Akzent6 Ana Ba?l?k Ana Başlık Ausgabe Ba?l? Hücre Ba?l?k 1 Ba?l?k 2 Ba?l?k 3 Ba?l?k 4 Bağlı Hücre Başlık 1 Başlık 2 Başlık 3 Başlık 4 Berechnung Ç?k?? Çıkış Eingabe Ergebnis Erklärender Text Giri? Giriş Gut İşaretli Hücre İyi Link Neutral Normal 2 Normal 2_Auflisten Seag Mai 2023 Normal 2_Tepperwein FSO Übs3 Normal 3 Normal 3 2 Normal 3 3 Normal_DriveFree LW Neu 2 Notiz Schlecht Stan dard Standard_Auflisten WD Medion Verify Juni 2023 Standard_Tabelle1 Standard_Tabelle1_1 Standard_ Tabelle1_1_zzAuflisten LW Sonja W8 2023 Standard_Tabelle1_1_zzz Vlg Dir Videos 2023 Standard_Tepp erwein FSO Übs3 Überschrift Überschrift 1 Überschrift 2 Überschrift 3 Überschrift 4 Uyar? Metni Uy arı Metni Verknüpfte Zelle Warnender Text Zelle überprüfen

ich habe nur das
' Dialog requires local format
SendKeys "{TAB 3}{DOWN}{ENTER}"

im Code. Hier das Makro.

Sub RemoveUnusedNumberFormats()
  Dim strOldFormat As String
  Dim strNewFormat As String
  Dim aCell As Range
  Dim sht As Worksheet
  Dim strFormats() As String
  Dim fFormatsUsed() As Boolean
  Dim i As Integer

  If ActiveWorkbook.Worksheets.Count = 0 Then
    MsgBox "The active workbook doesn't contain any worksheets.", vbInformation
    Exit Sub
  End If

  On Error GoTo Exit_Sub
  Application.Cursor = xlWait
  ReDim strFormats(1000)
  ReDim fFormatsUsed(1000)
  Set aCell = Range("A1")
  aCell.Select
  strOldFormat = aCell.NumberFormatLocal
  aCell.NumberFormat = "General"
  strFormats(0) = "General"
  strNewFormat = aCell.NumberFormatLocal
  i = 1
  Do
    ' Dialog requires local format
    SendKeys "{TAB 3}{DOWN}{ENTER}"
    Application.Dialogs(xlDialogFormatNumber).Show strNewFormat
    strFormats(i) = aCell.NumberFormat
    strNewFormat = aCell.NumberFormatLocal
    i = i + 1
  Loop Until strFormats(i - 1) = strFormats(i - 2)
  
  aCell.NumberFormatLocal = strOldFormat
  ReDim Preserve strFormats(i - 2)
  ReDim Preserve fFormatsUsed(i - 2)
  For Each sht In ActiveWorkbook.Worksheets
    For Each aCell In sht.UsedRange
      For i = 0 To UBound(strFormats)
        If aCell.NumberFormat = strFormats(i) Then
          fFormatsUsed(i) = True
          Exit For
        End If
      Next i
    Next aCell
  Next sht
  ' Suppress errors for built-in formats
  On Error Resume Next
  For i = 0 To UBound(strFormats)
    If Not fFormatsUsed(i) Then
      ' DeleteNumberFormat requires international format
      ActiveWorkbook.DeleteNumberFormat strFormats(i)
    End If
  Next i

Exit_Sub:
  Set aCell = Nothing
  Set sht = Nothing
  Erase strFormats
  Erase fFormatsUsed
  Application.Cursor = xlDefault
End Sub

Beliebteste Forumthreads (12 Monate)

Benutzerdef. Formate auflisten/ löschen

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Benutzerdef. Formate auflisten/ löschen

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread