Dateien (sukzessive) optimieren

Hallo,
ich habe einige Dateien bei denen ich zur Ressourcenentlastung sukzessive Formeln optimieren möchte. Da die Dateien sehr umfangreich sind, habe ich im Forum hier recherchiert und u.a. diese Tipps entdeckt:
https://www.herber.de/forum/archiv/1320to1324/t1320268.htm
Um die Formeln (die Bezüge zu anderen Tabellen in der Datei beinhalten) in den umfangreichen Dateien zu finden habe ich auch bereits ein Makro mit Hilfe des Forums:
https://www.herber.de/forum/archiv/1428to1432/t1431836.htm#1431836
Jetzt habe ich noch folgendes Problem: es gibt sehr viele Formeln die tausenderweise einfach in der Tabelle nach unten kopiert sind: mir genügt natürlich immer nur die "oberste Formelzeile".
Ich habe eine kleine Musterdatei mit dem Makro erstellt:
1. Es werden alle Formeln aufgelistet (siehe Tabelle "interne Formeln2")
2. In der Tabelle "interne Formeln2 sortiert" habe ich diese manuell sortiert und gelb markiert welche ich löschen kann (manuell).
http://www.file-upload.net/download-10706157/MusterVerkn--pfung.xlsm.html
Über den Server hier konnte ich nicht hochladen.
Ich sehe drei Möglichkeiten zur Optimierung:
a) Sortierung aus dem Makro wird bereits so angepasst, dass anschließend manuell die nicht benötigten Zeilen gelöscht werden können
b) Makro sucht sich immer nur die "erste Formelzelle" und listet die nachstehenden mit gleichem Inhalt gar nicht auf (beste Lösung)
c) eine Erleichterung wäre auch, wenn man pro Tabelle die Formeln ermitteln könnte, dann wäre die anschließende Nachbearbeitung leichter (also zuerst für Tab2, dann für Tab3 usw...).
Besten Dank für Anregungen / Hilfen.
mfg

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Erich,
so?

' **********************************************************************
' Modul: interneVerknüpfung  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Formeln_suchen_Blatt_intern2()
  'Auflistung aller Formeln mit Bezug zu einem anderen Blatt
  Dim Wks As Worksheet, wksFormeln As Worksheet
  Dim blnIndex As Boolean, rngF As Range, rngFormeln As Range, rngC As Range
  Dim lngZeile As Long, Kopf As Variant
  Dim I As Integer, vntWks As Variant
  Dim vntOut() As Variant, vntFormula() As Variant, lngN As Long
  
  On Error GoTo ErrExit
  
  Application.ScreenUpdating = False
  
  blnIndex = False
  lngZeile = 2
  '
  For Each Wks In Worksheets
    vntWks = vntWks & Wks.Name & "!|" & "'" & Wks.Name & "'!|"
  Next
  vntWks = Split(vntWks, "|")
  
  Redim Preserve vntFormula(lngN)
  
  For Each Wks In Worksheets
    Set rngFormeln = Nothing
    On Error Resume Next
    Set rngFormeln = Wks.Cells.SpecialCells(xlCellTypeFormulas)
    On Error GoTo 0
    If Not rngFormeln Is Nothing Then
      For Each rngF In rngFormeln.Columns
        For Each rngC In rngF.Cells(1, 1)
          For I = 0 To UBound(vntWks) - 1
            If Not Replace(Replace(vntWks(I), "'", ""), "!", "") = Wks.Name Then
              If InStr(rngC.FormulaLocal, vntWks(I)) Then
                Redim Preserve vntFormula(lngN)
                Redim Preserve vntOut(lngN)
                vntFormula(lngN) = "'" & rngC.FormulaLocal
                vntOut(lngN) = Array(Wks.Name, rngC.Address(0, 0), rngC.Row, rngC.Column)
                lngN = lngN + 1
              End If
            End If
          Next I
        Next
      Next
    End If
  Next
  
  
  Set wksFormeln = Worksheets.Add(after:=Sheets(Worksheets.Count))
  Kopf = Array("Blatt", "Zelle", "Zeile", "Spalte", "Formel")
  With wksFormeln
    .Name = "interneFormeln2"
    .Rows(1).Font.Bold = True
    .Range("A1:E1") = Kopf
    .Range("A2").Resize(UBound(vntOut, 1) + 1, 4) = Application.Transpose(Application.Transpose(vntOut))
    .Range("E2").Resize(UBound(vntFormula, 1) + 1, 1) = Application.Transpose(vntFormula)
    .Range("A1").AutoFilter 1, .Range("A2")
    .Columns.AutoFit
  End With
  
  If lngN = 0 Then
    MsgBox "Keine externen Bezüge vorhanden.", , ""
  Else
    wksFormeln.Activate
  End If
  ErrExit:
  Application.ScreenUpdating = True
  
  Set Wks = Nothing
  Set wksFormeln = Nothing
  Set rngC = Nothing
  Set rngF = Nothing
  Set rngFormeln = Nothing
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread