Hilfe bei Code

Public Sub FormelnAnpassen() Dim wks As Worksheet Dim z As Range Dim strSB As String, alteFormel As String, neueFormel As String Dim intFarbe As Integer, intAnt As Integer Dim q ''''''''''''''''''''''' Schleife von Anfang''''''''''''''''' Do q = 8 With ActiveSheet dsumme = WorksheetFunction.Sum(.Range(.Cells(9, 3), .Cells(12, 3))) dsumme2 = WorksheetFunction.Sum(.Range(.Cells(14, 3), .Cells(15, 3))) End With '''''''''''''''''''''Werte nacheinander einfügen''''''''''''' ActiveSheet.Cells(q + 1, 6) = dsumme ActiveSheet.Cells(q + 1, 7) = dsumme2 For Each wks In ThisWorkbook.Worksheets strSB = "C:\Beispiel\[test2.xlsx]" & wks.Index For Each z In wks.Range("c9:c15") If z.HasFormula = True And InStr(1, z.Formula, strSB) 0 Then wks.Activate z.Activate alteFormel = z.Formula neueFormel = Replace(alteFormel, _ "test2.xlsx]" & wks.Index, _ "test2.xlsx]" & wks.Index + 1) ''''''''''''''''''''''''''keine MsgBox''''''''''''''''''''' intAnt = MsgBox("soll die Formel in Zelle " & z.Address & " ersetzt werden?" _ & vbNewLine & vbNewLine _ & "alt:" & vbTab & alteFormel & vbNewLine _ & "neu:" & vbTab & neueFormel, vbYesNoCancel, "Formel ersetzen?") If intAnt = 6 Then z.Formula = neueFormel If intAnt = 2 Then Exit Sub End If ''''''''''''''Zellen aktualisieren''''''''''''''''''' Application.CalculateFullRebuild Next z Next wks Loop End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Public Sub FormelnAnpassen() Dim wks As Worksheet Dim z As Range Dim strSB As String, alteFormel As String, neueFormel As String Dim intFarbe As Integer, intAnt As Integer Dim q ''''''''''''''''''''''' Schleife von Anfang''''''''''''''''' Do q = 8 With ActiveSheet dsumme = WorksheetFunction.Sum(.Range(.Cells(9, 3), .Cells(12, 3))) dsumme2 = WorksheetFunction.Sum(.Range(.Cells(14, 3), .Cells(15, 3))) End With '''''''''''''''''''''Werte nacheinander einfügen''''''''''''' ActiveSheet.Cells(q + 1, 6) = dsumme ActiveSheet.Cells(q + 1, 7) = dsumme2 For Each wks In ThisWorkbook.Worksheets strSB = "C:\Beispiel\[test2.xlsx]" & wks.Index For Each z In wks.Range("c9:c15") If z.HasFormula = True And InStr(1, z.Formula, strSB) 0 Then wks.Activate z.Activate alteFormel = z.Formula neueFormel = Replace(alteFormel, _ "test2.xlsx]" & wks.Index, _ "test2.xlsx]" & wks.Index + 1) z.Formula = neueFormel End If ''''''''''''''Zellen aktualisieren''''''''''''''''''' Application.CalculateFullRebuild Next z Next wks Loop End Sub

Option Explicit Function Blaetter(ByVal sFile As String) As Long If Dir(sFile) "" Then Workbooks.Open Filename:=sFile Blaetter = Worksheets.Count ActiveWorkbook.Close savechanges:=False Else: Blaetter = -1 End If End Function Public Sub FormelnAnpassen() Dim q&, i&, bis& bis = Blaetter("C:\DeinPfad\DeineDatei.xlsx") If bis > 0 Then q = 8 For i = 1 To bis If i > 1 Then Cells.Replace What:="]" & i, Replacement:="]" & i + 1, LookAt:=xlPart, SearchOrder _ :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False End If Application.Calculate Cells(q + 1, 6) = WorksheetFunction.Sum(Range(Cells(9, 3), Cells(12, 3))) Cells(q + 1, 7) = WorksheetFunction.Sum(Range(Cells(14, 3), Cells(15, 3))) q = q + 1 Next ' Nach Makro wieder auf 1 setzen Cells.Replace What:="]" & i, Replacement:="]1", LookAt:=xlPart, SearchOrder _ :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False Else MsgBox "Fehler mit Blättern in der Datei" End If End Sub

Hi Michael,
jetzt muss ich doch nochmal nachfragen.
Es gibt zwei Dinge die ich gerne noch ändern würde.
1. Im Moment übergeht es mir das erste Tabellenblatt in der anderen Arbeitsmappe und fängt gleich mit dem zweiten an. Das erste Tabellenblatt wird erst auf Abfrage von Excel "auf welchen Wert zurück gesetzt werden soll" zum Schluss eingefügt.
Quasi soll der erste berechnete Wert aber sofort kopiert werden und im darauf folgenden Schritt die Formel verändert, neuberechnet, kopiert, usw werden.
2. Das nächste Problem was ich habe, was sich evtl jetzt durch das erste löst, ich kann das Makro nicht öfter laufen lassen. Wenn ich es einfüge funktioniert es einmal wunderbar, wenn ich es jetzt noch einmal laufen lasse funktioniert es aber nicht mehr. Das Makro kopiert mir dann immer die gleichen Werte von Tabellenblatt 1 in alle bereits gefüllten Zellen.
Meine Vermutung ist, dass die "das Makro wieder auf 1 setzen" Funktion das blockiert, da beim zweiten Durchlaufversuch nur Werte von Tabellenblatt eins ausgegeben werden.
Kannst du mir helfen die Herausforderung zu lösen :)
Viele Grüße
Anna

Anna,
da ist mir was durcheinandergekommen. Die Ersetzung der Nummern soll ja erst ab i=2 anfangen, damit zuerst mit 1 ausgewertet wird. Allerdings wird bei i=2 nicht die 1 durch die zwei ersetzt, da ich nach 2 suche - es passiert also rein gar nix, außer daß die immer gleichen Werte geschrieben werden.
Leider ist auch die Ersetzung ganz unten fehlerhaft, da Excel die seltsame Eigenschaft hat, Variablen nach einem Schleifendurchgang nochmal um 1 zu erhöhen, so daß i dann den Wert 10 hat - nach dem ] steht aber eine 9.
Hier ist bereits abzusehen, daß es doch nicht mehr funktioniert, sobald Du mehr 10 Blätter Daten hast: da wird nach 1 gesucht und 2 reingeschrieben, dann hast Du plötzlich nicht 11 statt 10, sondern 20.
Habe alles nochmal geändert, insbesondere das mit den Zeilen: gib bitte in Deiner Makro-Datei in Zelle G2 eine 8 ein, das holt sich das Makro, arbeitet 9 Blätter ab und schreibt dann eine 17 rein - so überschreiben sich die Werte nicht bei jedem Aufruf.
Also insgesamt so:

Function Blaetter(ByVal sFile As String, ByVal zeile As Long) As Long
Dim z&
If Dir(sFile)  "" Then
Workbooks.Open Filename:=sFile
Blaetter = ActiveWorkbook.Worksheets.Count
For z = 1 To Blaetter
'          Ausgabe der Blattnamen in SpalteH unter Tab.Name
ThisWorkbook.Sheets(1).Cells(zeile + z - 1, 8).Value = _
ActiveWorkbook.Worksheets(z).Name
Next
ActiveWorkbook.Close savechanges:=False
Else: Blaetter = -1
End If
End Function
Public Sub FormelnAnpassen()
Dim q&, i&, bis&
q = Range("G2").Value + 1
bis = Blaetter("C:\DeinPfad\DeineDatei.xlsx", q)
If bis > 0 Then
For i = 1 To bis
If i > 1 Then
Cells.Replace What:="]" & i - 1, Replacement:="]" & i, LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End If
Stop
Application.Calculate
Cells(q, 6) = WorksheetFunction.Sum(Range(Cells(9, 3), Cells(12, 3)))
Cells(q, 7) = WorksheetFunction.Sum(Range(Cells(14, 3), Cells(15, 3)))
Cells(q, 9) = i
'   Ausgabe von i Spalte I unter Var i
q = q + 1
Next
' Nach Makro wieder auf 1 setzen
Cells.Replace What:="]" & bis, Replacement:="]1", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Range("G2").Value = q - 1
Else
MsgBox "Fehler mit Blättern in der Datei"
End If
End Sub

Paß bitte auf, ich benutzt jetzt zusätzlich die Spalten H und I, um die Blattnummern auszugeben - falls das was Wichtiges steht, mußt Du die entsprechenden Zeilen im Code auskommentieren.
Happy Exceling,
Michael
P.S.: also doch mit direktem Öffnen und Auswerten, im Grunde ist es einfacher, da mit weniger Variablen hantiert wird:
Voraussetzung ist, daß die Datendatei geschlossen ist - oder noch abfragen

Sub ganzneu()
Dim q&, i&, bis&, summe#
Dim sFile$
q = Range("G2").Value + 1
sFile = "C:\DeinPfad\DeineDatei.xlsx"
If Dir(sFile)  "" Then
Workbooks.Open Filename:=sFile
bis = ActiveWorkbook.Worksheets.Count
For i = 1 To bis
summe = 0
summe = summe + WorksheetFunction.Sum(ActiveWorkbook.Sheets(i).Range("$A$1:$A$13"))
summe = summe + WorksheetFunction.Sum(ActiveWorkbook.Sheets(i).Range("$B$6:$B$11"))
' usw., was Du halt benötigst
ThisWorkbook.Sheets(1).Cells(q, 6).Value = summe
summe = 0
summe = summe + WorksheetFunction.Sum(ActiveWorkbook.Sheets(i).Range("$A$12:$A$17"))
summe = summe + WorksheetFunction.Sum(ActiveWorkbook.Sheets(i).Range("$B$12:$B$20"))
' usw., was Du halt benötigst
' in Deiner Beispieldatei überschneiden sich einige Summen sowieso, paß auf!
ThisWorkbook.Sheets(1).Cells(q, 7).Value = summe
q = q + 1
Next
ActiveWorkbook.Close savechanges:=False
Range("G2").Value = q - 1
Else
MsgBox "File not found"
End If
End Sub

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Hilfe bei Code

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread