Office: Erweitern eines Makros

User · 13. Januar 2020

Code:

Sub Segeltuch_VT_löschen()
'
' Segeltuch_VT_löschen Makro
'

'
'Application.EnableEvents = False '--Event ausschalten
Application.CutCopyMode = False
Selection.AutoFilter
Columns("C:C").Select
Selection.AutoFilter
ActiveSheet.Range("$C$1:$C$2000").AutoFilter Field:=1, Criteria1:= _
"*Zubehör S", Operator:=xlOr, Criteria2:="=*Zubehör VT"
Rows("38:2000").Select
Selection.Delete Shift:=xlUp
ActiveSheet.Range("$C$1:$C$2000").AutoFilter Field:=1
Columns("C:C").Select
Selection.Replace What:="/SS/", Replacement:="/", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("M7").Select
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Hallo, ich schon wieder, ich habe das Makro so aufgezeichnet.
Ich möchte den Teil:
Selection.Replace What:="/SS/", Replacement:="/", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
noch erweitern, das ersetzen von /SS/ durch / soll nur erfolgen wenn in der Zelle auch der Text: FK-EU vorkommt.
Wie kann ich das erweitern, Dankeschön.

:)

Flotter Feger · 15. Januar 2020

Hallo,

wie steht dein Suchstring denn in den Zellen ?

Idealerweise reicht eventuell eine Ergänzung der Strings ... blöderdings bräuchte es eventuell eine Schleife über alles selektierten Zellen.

Sabina

User · 15. Januar 2020

Hallo Sabina,
Danke für die Antwort.
was verstehst du unter Suchstring?

Die Zelle sieht so aus:
FK-EU***/SS/*** und soll dann so geändert werden FK-EU***/***

Bei den * ändert sich der Text, der Begin ist aber immer gleich.

Ich hoffe die Frage ist beantwortet.

Flotter Feger · 15. Januar 2020

Hallo,

wenn die Teilstrings nicht direkt aneinander anliegen, brauchst du eine Schleife.
Mit Array geht alles etwas schneller.
Code:

Dim i As Long
Dim cletzte As Long
Dim arrBereich As Variant

cletzte = Cells(Rows.Count, 3).End(xlUp).Row
arrBereich = Range("C1:C" & CStr(cletzte))

For i = LBound(arrBereich) To UBound(arrBereich)
If arrBereich(i, 1) Like "FE-EU*/SS/*" Then
arrBereich(i, 1) = Replace(arrBereich(i, 1), "/SS/", "/")
End If
Next i

Range("C1:C" & CStr(cletzte)) = arrBereich
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Sabina

User · 15. Januar 2020

Dankeschön, ich melden mich ob es geht *Smilie

User · 15. Januar 2020

leider funktioniert es nicht, bin mit nicht sicher wo ich es einfügen muss
Code:

Sub Segeltuch_VT_löschen()
'
' Segeltuch_VT_löschen Makro
'

'
'Application.EnableEvents = False '--Event ausschalten
Application.CutCopyMode = False
Selection.AutoFilter
Columns("C:C").Select
Selection.AutoFilter
ActiveSheet.Range("$C$1:$C$2000").AutoFilter Field:=1, Criteria1:= _
"*Zubehör S", Operator:=xlOr, Criteria2:="=*Zubehör VT"
Rows("38:2000").Select
Selection.Delete Shift:=xlUp
ActiveSheet.Range("$C$1:$C$2000").AutoFilter Field:=1
Columns("C:C").Select
Selection.Replace What:="/SS/", Replacement:="/", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("M7").Select

'--errechnet neue Summen
Dim bereich As Range, Zelle As Range
Dim wks As Worksheet
Set wks = Worksheets("EP-AG")
For Each Zelle In wks.Range(wks.Cells(38, 6), wks.Cells(Rows.Count, 6).End(xlUp)).SpecialCells(xlBlanks)
With Zelle
If Zelle.Offset(1, 0) "" Then
Set bereich = wks.Range(.Offset(0, 0).End(xlDown), .Offset(1, 0).End(xlDown))
If Application.CountBlank(bereich) Then
.Offset(, -1) = Zelle.Offset(1, 0)
Else
.Offset(, -1) = Application.Sum(bereich)
End If
Set bereich = Nothing
End If
End With
Next
Set wks = Nothing
'--zieht die Formeln runter
Range("J38:R38").AutoFill Destination:=Range("J38:R" & Cells(Rows.Count, 3).End(xlUp).Row), Type:=xlFillDefault

'Application.EnableEvents = True '--Event einschalten
Berechnen_Motornettopreis

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

ich habe es so abgeändert:
Code:

Sub Segeltuch_VT_löschen()
'
' Segeltuch_VT_löschen Makro
'

'
'Application.EnableEvents = False '--Event ausschalten
Application.CutCopyMode = False
Selection.AutoFilter
Columns("C:C").Select
Selection.AutoFilter
ActiveSheet.Range("$C$1:$C$2000").AutoFilter Field:=1, Criteria1:= _
"*Zubehör S", Operator:=xlOr, Criteria2:="=*Zubehör VT"
Rows("38:2000").Select
Selection.Delete Shift:=xlUp
' ActiveSheet.Range("$C$1:$C$2000").AutoFilter Field:=1
'Columns("C:C").Select
'Selection.Replace What:="/SS/", Replacement:="/", LookAt:=xlPart, _
' SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
' ReplaceFormat:=False
'Range("M7").Select

Dim i As Long
Dim cletzte As Long
Dim arrBereich As Variant

cletzte = Cells(Rows.Count, 3).End(xlUp).Row
arrBereich = Range("C1:C" & CStr(cletzte))

For i = LBound(arrBereich) To UBound(arrBereich)
If arrBereich(i, 1) Like "FE-EU*/SS/*" Then
arrBereich(i, 1) = Replace(arrBereich(i, 1), "/SS/", "/")
End If
Next i

Range("C1:C" & CStr(cletzte)) = arrBereich

'--errechnet neue Summen
Dim bereich As Range, Zelle As Range
Dim wks As Worksheet
Set wks = Worksheets("EP-AG")
For Each Zelle In wks.Range(wks.Cells(38, 6), wks.Cells(Rows.Count, 6).End(xlUp)).SpecialCells(xlBlanks)
With Zelle
If Zelle.Offset(1, 0) "" Then
Set bereich = wks.Range(.Offset(0, 0).End(xlDown), .Offset(1, 0).End(xlDown))
If Application.CountBlank(bereich) Then
.Offset(, -1) = Zelle.Offset(1, 0)
Else
.Offset(, -1) = Application.Sum(bereich)
End If
Set bereich = Nothing
End If
End With
Next
Set wks = Nothing
'--zieht die Formeln runter
Range("J38:R38").AutoFill Destination:=Range("J38:R" & Cells(Rows.Count, 3).End(xlUp).Row), Type:=xlFillDefault

'Application.EnableEvents = True '--Event einschalten
Berechnen_Motornettopreis

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Wenn ich es ausführen kommt der Fehler 400 und die Tabelle ist weg.
Was mache ich falsch.

Flotter Feger · 15. Januar 2020

Hallo,

theoretisch ... gar nichts ... sieht alles gut aus ... praktisch ... alles Mögliche.

Ohne deine Datei zu kennen, wäre das pures Raten.

Sabina

User · 15. Januar 2020

Schade trotzdem Dankeschön

Flotter Feger · 15. Januar 2020

*confused.gif* *confused.gif* *confused.gif*

User · 15. Januar 2020

Hallo Sabina,
danke noch mal für das erstellen, ich habe dir mal einen Teil der Liste hochgeladen.
Vielleicht kannst du es daran erkennen.

hary · 15. Januar 2020

Moin
Ungetestet, da mit Handy.
Code:

Sub Segeltuch_VT_löschen()
Dim i As Long
Dim cletzte As Long
Dim arrBereich As Variant
cletzte = Cells(Rows.Count, 3).End(xlUp).Row
arrBereich = Range("C29:C" & CStr(cletzte))
For i = LBound(arrBereich) To UBound(arrBereich)
If arrBereich(i, 1) Like "FK*/SS/*" Then
arrBereich(i, 1) = Replace(arrBereich(i, 1), "/SS/", "/")
End If
Next i
Range("C29:C" & CStr(cletzte)) = arrBereich
Application.CutCopyMode = False
Selection.AutoFilter
Columns("C:C").Select
Selection.AutoFilter
ActiveSheet.Range("$C$1:$C$2000").AutoFilter Field:=1, Criteria1:= _
"*Zubehör S", Operator:=xlOr, Criteria2:="=*Zubehör VT"
Rows("29:2000").Select
Selection.Delete Shift:=xlUp
'--errechnet neue Summen
Dim bereich As Range, Zelle As Range
Dim wks As Worksheet
Set wks = Worksheets("Angebot")
For Each Zelle In wks.Range(wks.Cells(29, 6), wks.Cells(Rows.Count, 6).End(xlUp)).SpecialCells(xlBlanks)
With Zelle
If Zelle.Offset(1, 0) "" Then
Set bereich = wks.Range(.Offset(0, 0).End(xlDown), .Offset(1, 0).End(xlDown))
If Application.CountBlank(bereich) Then
.Offset(, -1) = Zelle.Offset(1, 0)
Else
.Offset(, -1) = Application.Sum(bereich)
End If
Set bereich = Nothing
End If
End With
Next
Set wks = Nothing
ActiveSheet.ShowAllData '-- Filter alles zeigen, ansonsten Fehler
'--zieht die Formeln runter
Range("J28:P28").AutoFill Destination:=Range("J28:P" & Cells(Rows.Count, 3).End(xlUp).Row), Type:=xlFillDefault
'Berechnen_Motornettopreis
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

gruss hary

User · 19. Januar 2020

Hallo hary,
Dankeschön, habe gar nicht gesehen das du geantwortet hast.
Habe nur noch das:
Code:

ActiveSheet.ShowAllData '-- Filter alles zeigen, ansonsten Fehler
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Verschieben müssen da sonnst due Summe nicht berechnet wurde schon hat es geklappt!
Dankeschön. *biggrin.gif*

Lieder kommt noch ein Fehler bei dem Makro:

Code:

Sub Hohlen_Deckblatt() ' Wir verwendet löst den Fehler aus

Tabelle3.Application.EnableEvents = False '--Event ausschalten
'-- holt die Daten aus der(wenn geoeffneten) Mappe "DE****"
Dim wbk As Workbook
Dim lngLetzeZeile As Long, lngLetzeZeile2 As Long, i As Long
Dim offen As Boolean
Application.ScreenUpdating = False '--Bildschirmflackern ausschalten
'Set wbk = Worksheets("RV-Deckblatt")
' Zellen auflösen
Range("E1:J1").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge

For Each wbk In Workbooks '--Schleife ueber geoeffnete Mappen
If wbk.Name Like "DE*" Then '--wenn Mappenname beginnt mit DE

With Workbooks(wbk.Name).Worksheets("Sheet1") '--ggf. Blattname anpassen
.Range("C2").copy Cells(5, "N")
.Range("D2").copy Cells(5, "D")
.Range("C4").copy Cells(1, "E")
.Range("C1").copy Cells(26, "D")
.Range("C4").copy Cells(26, "F")

'.Cells(26, "D").Value = CLng(.Cells(1, "C").Value) & .Cells(4, "C").Value
'Tabelle2.Cells(1, 1).Value = CLng(Tabelle1.Cells(1, 1).Value) & Tabelle1.Cells(1, 2).Value
'For i = 1 To .Cells(.Rows.Count, "C").End(xlUp).Row
'--sucht belegte Zeile
'If Application.CountA(.Cells(i, 1).Resize(1, 9)) = 9 Then
' lngLetzeZeile2 = i
'Exit For
'End If
'Next
'Application.EnableEvents = True '--Event einschalten
'-----
' .Range("A" & lngLetzeZeile2 + 1 & ":H" & .Cells(.Rows.Count, "C").End(xlUp).Row).Copy Cells(38, "A") 'H auf I ändern wenn PG Deteils gewünscht

'Namen einfügen
Range("D81") = Application.UserName
Range("C80") = Application.UserName & " Trox GmbH"

Application.CutCopyMode = False
End With
offen = True
Exit For '--Schleife beenden
End If
Next
If Not offen Then '--wenn betr. Mappe nicht offen
MsgBox "passende Mappe nicht offen", vbCritical, "Hinweis"
Exit Sub '--Makro beenden
End If

' Felder ohne Hintergrungfarbe Anpassung

Range("D26:F26").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("D5").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("E1").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("N5").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("E1:J1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection.Font
.ThemeColor = xlThemeColorAccent1
.TintAndShade = -0.249977111117893
End With
Selection.Font.Bold = True
Range("N5").Select
Selection.Font.Bold = True
With Selection.Font
.ThemeColor = xlThemeColorAccent1
.TintAndShade = -0.249977111117893
End With
Range("D5").Select
With Selection.Font
.ThemeColor = xlThemeColorAccent1
.TintAndShade = -0.249977111117893
End With
Selection.Font.Bold = True
Range("D26").Select
With Selection.Font
.ThemeColor = xlThemeColorAccent1
.TintAndShade = -0.249977111117893
End With
Selection.Font.Bold = True
Range("F26").Select
Selection.Font.Bold = True
With Selection.Font
.ThemeColor = xlThemeColorAccent1
.TintAndShade = -0.249977111117893
End With

ActiveWindow.SmallScroll Down:=-3

Tabelle3.Application.EnableEvents = True '--Event einschalten

Tabelle3.Hohlen_EP_AG

Tabelle3.Berechnen_Motornettopreis

Tabelle3.letzte_zelle

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Laufzeitfehler 1004
Die Methode Range für das Objekt-Worksheet ist fehlgeschlagen

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Cells.Count > 1 Then Exit Sub
If Intersect(Target, Range("$N$3, $O$3, $R$3, $R$4")) Is Nothing Then Exit Sub

Tabelle3.Berechnen_Motornettopreis
' MsgBox " Makro gestartet"
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Debuggen macht das gelb: If Intersect(Target, Range("$N$3, $O$3, $R$3, $R$4")) Is Nothing Then Exit

Ich habe aber die Applikation ausgeschalter woran kann das liegen?

Danke noch mal für die Hilfe.

User · 19. Januar 2020

Hallo zusammen,

noch mal danke, den Fehler hab ich wegbekommen!

User · 28. Januar 2020

Code:

Sub Segeltuch_VT_löschen_NEU2() ' wird verwendet

' Segeltuch_VT_löschen nur bei der FK-EU liegt am Programm LN

Dim i As Long
Dim cletzte As Long
Dim arrBereich As Variant
cletzte = Cells(Rows.Count, 3).End(xlUp).Row
arrBereich = Range("C69:C" & CStr(cletzte))
For i = LBound(arrBereich) To UBound(arrBereich)
If arrBereich(i, 1) Like "FK-EU*/SS/*" Then
arrBereich(i, 1) = Replace(arrBereich(i, 1), "/SS/", "/")
End If
Next i
Range("C69:C" & CStr(cletzte)) = arrBereich
Application.CutCopyMode = False
Selection.AutoFilter
Columns("C:C").Select
Selection.AutoFilter
ActiveSheet.Range("$C$1:$C$2000").AutoFilter Field:=1, Criteria1:= _
"*Zubehör S", Operator:=xlOr, Criteria2:="=*Zubehör VT"
Rows("69:2000").Select
Selection.Delete Shift:=xlUp

'ActiveSheet.ShowAllData '-- Filter alles zeigen, ansonsten Fehler
'--errechnet neue Summen
Dim bereich As Range, Zelle As Range
Dim wks As Worksheet
Set wks = Worksheets("Angebot")
For Each Zelle In wks.Range(wks.Cells(69, 6), wks.Cells(Rows.Count, 6).End(xlUp)).SpecialCells(xlBlanks)
With Zelle
If Zelle.Offset(1, 0) "" Then
Set bereich = wks.Range(.Offset(0, 0).End(xlDown), .Offset(1, 0).End(xlDown))
If Application.CountBlank(bereich) Then
.Offset(, -1) = Zelle.Offset(1, 0)
Else
.Offset(, -1) = Application.Sum(bereich)
End If
Set bereich = Nothing
End If
End With
Next
Set wks = Nothing
ActiveSheet.ShowAllData '-- Filter alles zeigen, ansonsten Fehler
'--zieht die Formeln runter
Range("J68:U68").AutoFill Destination:=Range("J68:U" & Cells(Rows.Count, "C").End(xlUp).Row), Type:=xlFillDefault

BerechnenMotornettopreis
Range("M1").Select
'ZeilenAusblenden
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Leider kommt bei dem Makro immer noch ein Fehler 400.

User · 28. Januar 2020

Hab es jetzt gelöst! Danke noch mal.

Office: Erweitern eines Makros

Erweitern eines Makros

Erweitern eines Makros

Erweitern eines Makros

Erweitern eines Makros

Erweitern eines Makros

Erweitern eines Makros - Similar Threads - Erweitern Makros

Filter()-Funktion: gefilterte Tabelle erweitern

Formelbezug automatisch erweitern

XY-Diagramm-Grafik mit zusätzlichen Daten erweitern

Aktualisierbare Tabelle um manuelle Werte erweitern

VBA Code erweitern

Intelligente Tabelle erweitern trotz Blattschutz

Formel in Tabelle einer Abfrage automatisch erweitern