PDA

Vollständige Version anzeigen : Suchen, einfügen, berechnen


supportochse
05.05.2009, 15:08
Hallo,

nach vergeblicher Suche hier im Forum und Abbruch des Versuchs
aus mehreren Beiträgen eine Lösung zu finden, hier mein Problem:
ich will eine Excelseite nach bestimmten Zeichen (hier RS) durchsuchen,
dann darüber eine Zeile einfügen, in dieser Zeile bestimmte Zellen
der darunter liegenden kopieren (Spalte A:G) und in dieser neuen Zeile
auch ab einer bestimmten Spalte (H:J) die Summe ziehen aus den 2 darunter liegenden Zeilen. Anschließend zum nächsten Zeichensatz springen, das Selbe durchführen, bis das Blattende erreicht ist.

Nach meiner Makroaufnahme und Modifikation, kam eine Endlosschleife
heraus. Vielleicht kann mir jemand auf die Sprünge helfen...

vielen Dank! SO

Sub SchlussRGSaldoAus()
'
' SchlussRGSaldoAus Makro
' Makro am 23.04.2009 aufgezeichnet
'
' Tastenkombination: Strg+ä
'
With Worksheets(1).Range("a1:j32000")
Set c = .Find(what:="RS")
If Not c Is Nothing Then
firstAddress = c.Address
Do
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("H").Select
ActiveCell.FormulaR1C1 = "=R[-2]C+R[-1]C"
Range("H").Select
Selection.AutoFill Destination:=Range("H:J"), Type:=xlFillDefault
Range("H:J").Select
Range("G").Select
ActiveCell.FormulaR1C1 = "=R[-2]C"
Range("G").Select
Selection.AutoFill Destination:=Range("A:G"), Type:=xlFillDefault
Range("A:G").Select
Range("D").Select
Selection.Copy
Range("D").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Rows.Select
Selection.EntireRow.Hidden = True
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub
Code-Tags gesetzt

NoNet
05.05.2009, 15:35
Hallo S.,

wenn ich Deine Aufgabenstellung richtig verstanden habe, sollte folgendes Makro funktionieren :

Sub SchlussRGSaldoAusNoNet()
'
' SchlussRGSaldoAus -Lösungsvorschlag von NoNet, 05.05.2009
' Tastenkombination: Strg+ä

'ich will eine Excelseite nach bestimmten Zeichen (hier RS) durchsuchen,
'dann darüber eine Zeile einfügen, in dieser Zeile bestimmte Zellen
'der darunter liegenden kopieren (Spalte A:G) und in dieser neuen Zeile
'auch ab einer bestimmten Spalte (H:J) die Summe ziehen aus den 2 darunter liegenden Zeilen.
'Anschließend zum nächsten Zeichensatz springen, das Selbe durchführen, bis das Blattende erreicht ist.

Dim rngZelle As Range
Dim strFirstAddress As String

With Worksheets(1).Range("A1:J32000")
Set rngZelle = .Find(what:="RS")
If Not rngZelle Is Nothing Then
strFirstAddress = rngZelle.Offset(1).Address
Do
rngZelle.EntireRow.Insert Shift:=xlDown
Range(Cells(rngZelle.Row + 1, 1), Cells(rngZelle.Row + 1, 7)).Copy Cells(rngZelle.Row - 1, 1)
Range(Cells(rngZelle.Row - 1, 8), Cells(rngZelle.Row - 1, 10)).FormulaR1C1 = "=R[1]C+R[2]C"
Set rngZelle = .FindNext(rngZelle)
Loop While Not rngZelle Is Nothing And rngZelle.Address <> strFirstAddress
End If
End With
End Sub


Bitte teste das Makro aber zunächst an einer Kopie Deiner Tabelle !!

supportochse
06.05.2009, 13:23
Hallo NoNet,

vielen Dank für die Antwort. Habe dein Makro getestet und es verändert
nur die Zeilen 11 bis 18. Und fügt keine neue Zelle ein, sondern überschreibt.

Ich habe mal ne xls rangehängt damit man versteht was ich meine. In Tabelle 1 das Original und in 1(2) die Veränderung in grün.

Good Luck :)

NoNet
06.05.2009, 14:22
Hey Supportochse,

das Problem wird vermutlich dadurch verursacht, dass nicht nur in Spalte C "RS" enthalten ist, sondern z.B. auch in Spalte F ("...Jeepers Peepers").

Sucht man nur in Spalte C nach "RS", dann klappt das Makro nach meinem Verständnis :
Sub SchlussRGSaldoAusNoNet()
'
' SchlussRGSaldoAus -Lösungsvorschlag von NoNet, 05./06.05.2009
' Tastenkombination: Strg+ä

'ich will eine Excelseite nach bestimmten Zeichen (hier RS) durchsuchen,
'dann darüber eine Zeile einfügen, in dieser Zeile bestimmte Zellen
'der darunter liegenden kopieren (Spalte A:G) und in dieser neuen Zeile
'auch ab einer bestimmten Spalte (H:J) die Summe ziehen aus den 2 darunter liegenden Zeilen.
'Anschließend zum nächsten Zeichensatz springen, das Selbe durchführen, bis das Blattende erreicht ist.

Dim rngZelle As Range
Dim strFirstAddress As String

With Worksheets(1).[C:C] 'Range("A1:J32000") 'Nur in Spalte C nach "RS" suchen
If [C1].Value = "RS" Then 'Falls bereits in C1 "RS" steht
Set rngZelle = [C1]
Else
Set rngZelle = .Find(what:="RS")
End If

If Not rngZelle Is Nothing Then
strFirstAddress = rngZelle.Offset(1).Address
Do
rngZelle.EntireRow.Insert Shift:=xlDown
Range(Cells(rngZelle.Row + 1, 1), Cells(rngZelle.Row + 1, 7)).Copy Cells(rngZelle.Row - 1, 1)
Range(Cells(rngZelle.Row - 1, 8), Cells(rngZelle.Row - 1, 10)).FormulaR1C1 = "=R[1]C+R[2]C"
Range(Cells(rngZelle.Row - 1, 1), Cells(rngZelle.Row - 1, 10)).Interior.Color = vbCyan 'hellblau färben !
Set rngZelle = .FindNext(rngZelle)
Loop While Not rngZelle Is Nothing And rngZelle.Address <> strFirstAddress
End If
End With
End Sub
In Deiner Tabelle werden nun 8 neue Zeilen (hier im Makro hellblau gefärbt !) eingefügt.

supportochse
06.05.2009, 16:39
Hi NoNet,

das ist es im Prinzip!

Was jetzt noch perfekt sein würde, wenn die ersten
Spalten (A bis B und D bis G) aus der "RS" Zeile kommen würden,
denn

rngZelle.EntireRow.Insert Shift:=xlDown
Range(Cells(rngZelle.Row + 1, 1), Cells(rngZelle.Row + 1, 7)).Copy Cells(rngZelle.Row - 1, 1)

gibt ja die Werte aus der Zeile darunter wieder.

"RS" selbst muss man ausschließen, sonst wird es wieder ne Endlosschleife.
Habe mich daran versucht, aber mein Anfängerwissen ließ mich scheitern.

Vielen Dank für die Lösung!

SO

NoNet
06.05.2009, 16:58
Hallo SO,

das klappt mit folgendem angepassten Code :
Sub SchlussRGSaldoAusNoNet()
'
' SchlussRGSaldoAus -Lösungsvorschlag von NoNet, 05./06.05.2009
' Tastenkombination: Strg+ä

'ich will eine Excelseite nach bestimmten Zeichen (hier RS) durchsuchen,
'dann darüber eine Zeile einfügen, in dieser Zeile bestimmte Zellen
'der darunter liegenden kopieren (Spalte A:G) und in dieser neuen Zeile
'auch ab einer bestimmten Spalte (H:J) die Summe ziehen aus den 2 darunter liegenden Zeilen.
'Anschließend zum nächsten Zeichensatz springen, das Selbe durchführen, bis das Blattende erreicht ist.

Dim rngZelle As Range
Dim strFirstAddress As String

With Worksheets(1).[C:C] 'Range("A1:J32000") 'Nur in Spalte C nach "RS" suchen
If [C1].Value = "RS" Then 'Falls bereits in C1 "RS" steht
Set rngZelle = [C1]
Else
Set rngZelle = .Find(what:="RS")
End If

If Not rngZelle Is Nothing Then
strFirstAddress = rngZelle.Offset(1).Address
Do
rngZelle.EntireRow.Insert Shift:=xlDown
'Range(Cells(rngZelle.Row + 1, 1), Cells(rngZelle.Row + 1, 7)).Copy Cells(rngZelle.Row - 1, 1)

'*** Neue Codezeilen : Spalte 1 bis 2 un d Spalte 4 bis 7 aus "RS-Zeile" kopieren : ****
Range(Cells(rngZelle.Row, 1), Cells(rngZelle.Row, 2)).Copy Cells(rngZelle.Row - 1, 1)
Range(Cells(rngZelle.Row, 4), Cells(rngZelle.Row, 7)).Copy Cells(rngZelle.Row - 1, 4)
'***** Ende der neuen Codezeilen *********************************************************

Range(Cells(rngZelle.Row - 1, 8), Cells(rngZelle.Row - 1, 10)).FormulaR1C1 = "=R[1]C+R[2]C"
Range(Cells(rngZelle.Row - 1, 1), Cells(rngZelle.Row - 1, 10)).Interior.Color = vbCyan 'hellblau färben !
Set rngZelle = .FindNext(rngZelle)
Loop While Not rngZelle Is Nothing And rngZelle.Address <> strFirstAddress
End If
End With
End Sub