Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1036to1040
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

@Tino -> Help!

@Tino -> Help!
13.01.2009 14:07:00
Claudia
Hallo Tino,
mittels des nachfolgenden Makros lese ich Formeln und Funktionen aus:

Sub FormelnUndFunktionenDokumentieren()
Dim i As Integer
Dim zelle As Range
Dim s As String
Dim l As Long
Sheets.Add Before:=Worksheets(1)
s = ActiveSheet.Name
l = 1
Sheets(s).Cells(l, 1).Value = "Tabelle"
Sheets(s).Cells(l, 2).Value = "Zelle"
Sheets(s).Cells(l, 3).Value = "Formel/Funktion"
Sheets(s).Cells(l, 4).Value = "Inhalt"
Range(Cells(l, 1), Cells(l, 4)).Font.Bold = True
l = l + 1
For i = 2 To ThisWorkbook.Worksheets.Count
Worksheets(i).Activate
On Error Resume Next
Selection.SpecialCells(xlCellTypeFormulas).Select
For Each zelle In Selection
Sheets(s).Cells(l, 1).Value = Worksheets(i).Name
Sheets(s).Cells(l, 2).Value = zelle.Address
Sheets(s).Cells(l, 3).Value = "'" & zelle.FormulaLocal
Sheets(s).Cells(l, 4).Value = zelle.Value
l = l + 1
Next zelle
Next i
Sheets(s).Columns("A:D").AutoFit
End Sub


In einer separaten Tabelle stehen also die Formeln drin:
Spalte A Tabellenblatt
Spalte B Zelle
Spalte C Formel / Funktion
Spalte D Inhalt
Wenn ich nun feststelle, das da ein Formel falsch ist, dann würde ich diese falsche Formeln gerne in der separaten Tabellenblatt in Spalte C ändern. Und mittels Makro soll dann die Formel in die richtige Zelle des richtigen richtigen Tabellenblatt eingefügt werden.
Hintergrund: Ich muss 20 Tabellenblätter auf die richtigen Formeln prüfen, weil ich diese Datei übernommen habe. Vermutlich sind etliche Formlen falsch, weil man hier kopiert hat. Da passiert das halt.
Händisch wäre ich wohl einige Zeit beschäftigt.
Danke im Voraus, dass Du Dir das mal anschaut. Super wäre, wenn Du auch noch eine Lösung hättest.
Liebe Grüße
Claudia

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

Betreff
Datum
Anwender
Anzeige
AW: @Tino -> Help!
13.01.2009 14:48:00
Tino
Hallo,
Makro muss vom neuen Tabellenblatt aus gestartet werden.
Option Explicit

Sub FormelnUndFunktionenDokumentieren()
Dim i As Integer
Dim zelle As Range
Dim s As String
Dim l As Long
Dim NeuSeet As Worksheet
Set NeuSeet = Sheets.Add(Before:=Worksheets(1))

l = 1
NeuSeet.Cells(l, 1).Value = "Tabelle"
NeuSeet.Cells(l, 2).Value = "Zelle"
NeuSeet.Cells(l, 3).Value = "Formel/Funktion"
NeuSeet.Cells(l, 4).Value = "Inhalt"
NeuSeet.Range(NeuSeet.Cells(l, 1), NeuSeet.Cells(l, 4)).Font.Bold = True
l = l + 1

For i = 2 To ThisWorkbook.Worksheets.Count
 With Worksheets(i)
    On Error Resume Next
        
        For Each zelle In .Cells.SpecialCells(xlCellTypeFormulas)
         If zelle.FormulaLocal = "" Then GoTo Fehler:
          NeuSeet.Cells(l, 1).Value = .Name
          NeuSeet.Cells(l, 2).Value = zelle.Address
          NeuSeet.Cells(l, 3).Value = "'" & zelle.FormulaLocal
          NeuSeet.Cells(l, 4).Value = zelle.Value
          l = l + 1
Fehler: Next zelle


 End With
Next i

Columns("A:D").AutoFit
End Sub


Sub ZurückSchreiben()
Dim Bereich As Range
Dim myArea
Dim i As Long

Set Bereich = Range("A2:C" & Cells(Rows.Count, 1).End(xlUp).Row)
myArea = Bereich

For i = 1 To Ubound(myArea, 1)
 If myArea(i, 1) <> "" And myArea(i, 2) <> "" And myArea(i, 3) <> "" Then
  Sheets(CStr(myArea(i, 1))).Range(CStr(myArea(i, 2))).FormulaLocal = myArea(i, 3)
 ElseIf myArea(i, 1) <> "" And myArea(i, 2) <> "" Then
  Sheets(CStr(myArea(i, 1))).Range(CStr(myArea(i, 2))).Value = ""
 End If
Next i



End Sub


Gruß Tino

Anzeige
@ Tino: Du bist wirklich mein VBA-Held!
13.01.2009 15:18:00
Claudia
Einfach super. Jetzt hast Du mir schon zum wiederholten Male geholfen. Und das ist so kurzer Zeit, so dass man denken könnte, Du hast das Makro schon und holst es einfach nur raus.
Einfach toll und herzlichen Dank! Damit hast Du mir eine Menge Arbeit und vermutlich auch Fehler erspart.
Schönen Tag noch
danke für die positive Rückmeldung oT.
13.01.2009 15:29:00
Tino
Formeln pro Zelle dokumentieren
14.01.2009 17:08:00
Claudia
Hallo Tino, hallo zusammen,
habe noch eine Frage im Anschluss (Tino: Das erste Makro war eine Klasse Verbesserung).
Kann man das nachfolgende Makro

Sub FormelnUndFunktionenDokumentieren()
Dim i As Integer
Dim zelle As Range
Dim s As String
Dim l As Long
Sheets.Add Before:=Worksheets(1)
s = ActiveSheet.Name
l = 1
Sheets(s).Cells(l, 1).Value = "Tabelle"
Sheets(s).Cells(l, 2).Value = "Zelle"
Sheets(s).Cells(l, 3).Value = "Formel/Funktion"
Sheets(s).Cells(l, 4).Value = "Inhalt"
Range(Cells(l, 1), Cells(l, 4)).Font.Bold = True
l = l + 1
For i = 2 To ThisWorkbook.Worksheets.Count
Worksheets(i).Activate
On Error Resume Next
Selection.SpecialCells(xlCellTypeFormulas).Select
For Each zelle In Selection
Sheets(s).Cells(l, 1).Value = Worksheets(i).Name
Sheets(s).Cells(l, 2).Value = zelle.Address
Sheets(s).Cells(l, 3).Value = "'" & zelle.FormulaLocal
Sheets(s).Cells(l, 4).Value = zelle.Value
l = l + 1
Next zelle
Next i
Sheets(s).Columns("A:D").AutoFit
End Sub


erweitern um den Ansatz, dass für jede vorliegende Zelle (die eine Formel oder Fuktion hat) auch die gleichlautende Zelle der anderen Tabellen geprüft wird?
Beispiel:
Tabelle 1 Zelle A2 keine Formeln
Tabelle 2 Zelle A2 hat eine Formel
Das bestehende Makro listet nun Tabelle 2 A2 aus. Die erste Tabelle wird nicht erwähnt, so dass ich nur mit intensiver Prüfung erkennen kann, dass hier was fehlt.
Nun soll das Makro die Zelle A2 für alle Tabellen auflisten, so dass man erkennen kann, dass in einer Zelle z.B. die Formel vergessen wurde (Hintergrund: Die Tabellen sind alle gleich aufgebaut, nur die Formeln könnten vermutlich nicht überall drin sein). Mit den anderen Zellen soll das gleich passieren.
Also erst alle Zellen mit Formeln udn Funktionen auslesen und dann noch einmal mit diesen Werten die Tabellen durchlaufen und alle gleichlautenden Zellen (die keine Formel oder Funktion haben) auflisten, so dass man das in der Überscht direkt erkennen kann.
Habe mich wohl vermutlich jetzt sehr wirr ausgedrückt, aber ich kann es nicht besser erklären.
Liebe Grüße und danke
Claudia

Anzeige
fertig zum testen?
14.01.2009 18:44:09
Tino
Hallo,
teste mal ob es so geht.
Option Explicit
Private Declare Sub GetSafeArrayPointer Lib "msvbvm60.dll" Alias "GetMem4" _
                    (pArray() As Any, sfaPtr As Long)
Sub FormelnUndFunktionenDokumentieren()
   Dim i As Integer, ii As Integer, iii As Integer
   Dim zelle As Range
   Dim s As String
   Dim l As Long
   Dim myArea() As String
   Dim strInfo() As String
   Dim sfaPtr As Long


   
   Sheets.Add Before:=Worksheets(1)
   s = ActiveSheet.Name
   l = 1
   Sheets(s).Cells(l, 1).Value = "Tabelle"
   Sheets(s).Cells(l, 2).Value = "Zelle"
   Sheets(s).Cells(l, 3).Value = "Formel/Funktion"
   Sheets(s).Cells(l, 4).Value = "Inhalt"
   Rows(1).Font.Bold = True
   l = l + 1
   
   Redim myArea(0 To ThisWorkbook.Worksheets.Count - 2)
   For ii = 2 To ThisWorkbook.Worksheets.Count
    myArea(ii - 2) = ThisWorkbook.Worksheets(ii).Name
   Next ii
   
   For i = 2 To ThisWorkbook.Worksheets.Count
'   Worksheets(i).Activate 
   On Error Resume Next
'        Selection.SpecialCells(xlCellTypeFormulas).Select 
        For Each zelle In Worksheets(i).Cells.SpecialCells(xlCellTypeFormulas)
        If zelle.FormulaLocal = "" Then GoTo Fehler:
         Sheets(s).Cells(l, 1).Value = Worksheets(i).Name
         Sheets(s).Cells(l, 2).Value = zelle.Address
         Sheets(s).Cells(l, 3).Value = "'" & zelle.FormulaLocal
         Sheets(s).Cells(l, 4).Value = zelle.Value
         
         For ii = Lbound(myArea) To Ubound(myArea)
          If Worksheets(i).Name <> myArea(ii) Then
           If Sheets(myArea(ii)).Range(zelle.Address).FormulaLocal <> zelle.FormulaLocal Then
            Redim Preserve strInfo(iii)
            strInfo(iii) = myArea(ii)
            iii = iii + 1
           End If
          End If
         Next ii
         iii = 0
         
         GetSafeArrayPointer strInfo, sfaPtr
         If sfaPtr > 0 Then
          Sheets(s).Cells(l, 5).Resize(, Ubound(strInfo) + 1) = strInfo
          Sheets(s).Cells(l, 5).Resize(, Ubound(strInfo) + 1).Font.ColorIndex = 3
          Sheets(s).Cells(1, 5).Resize(, Ubound(strInfo) + 1).Value = "Fehlt in"
         End If
         Erase strInfo
         
         l = l + 1
Fehler:  Next zelle
    Next i
   
   Sheets(s).Columns("A:D").AutoFit
   End Sub


Gruß Tino

Anzeige
Ich bin überwältigt....
14.01.2009 20:00:06
Claudia
Hallo Tino,
das ist noch besser als ich es mir vorgestellt habe. :-)
Werde es morgen auf der Arbeit richtig durchtesten.
Vielen vielen Dank!
Schönen Abend und liebe Grüße
Claudia

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige