Office: Ich bekomme das Makro nicht hin

User · 27. Januar 2020

Hallo zusammen ich habe probleme mit dem Makro.

Hier hat mit Hary sehr geholfen, danke noch mal dafür.

Leider klappt der tein nicht:

Code:

Dim i As Long
'Dim i2 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
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Es wird nicht "/SS/" durch "/" ersetzt, wie erweitere ich den Teil das auch noch das nach "FK-EU*/0S/" und "FK-EU*/S0/" gesucht wird und dann "/S0/" oder "/0S/" durch "/" ersetzt wird?

Code:

'--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
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Hier fehlt noch die Erweiterung auf das der die Summe die in z.B. in E69 mit der Menge aus D69 multipliziert wird und dann in G 69 eingefügt wird.

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 i2 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

SSundVTLöschen

'For i2 = Cells(Rows.Count, "C").End(xlUp).Row To 1 Step -1
' If Cells(i2, "C") = "FK-EU Zubehör S" Or Cells(i, "C") = "FK-EU Zubehör VT" Then Rows(i2).Delete
' Next i2

'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
'FarbSchleife
'BerechnenMotornettopreis
'FarbSchleife
Range("M1").Select
'ZeilenAusblenden

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

Wäre super, wenn mir da wer helfen könnte.

:)

Der Steuerfuzzi · 9. Februar 2021

Hallo,

von TZA

wie erweitere ich den Teil das auch noch das nach "FK-EU*/0S/" und "FK-EU*/S0/" gesucht wird und dann "/S0/" oder "/0S/" durch "/" ersetzt wird?
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Hier ein Vorschlag: Code:

If arrBereich(i, 1) Like "FK-EU*/S[0S]/*" Or arrBereich(i, 1) Like "FK-EU*/[0S]S/*" Then
arrBereich(i, 1) = Replace(Replace(Replace(arrBereich(i, 1), "/SS/", "/"), "/S0/", "/"), "/0S/", "/")
End If
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

von TZA

Hier fehlt noch die Erweiterung auf das der die Summe die in z.B. in E69 mit der Menge aus D69 multipliziert wird und dann in G 69 eingefügt wird.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Eventuell so? Code:

'--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
.Offset(, 1) = Offset(,-1) * Offset(,-2)
Set Bereich = Nothing
End If
End With
Next
Set wks = Nothing
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Schau mal, ob es so passt.

User · 29. Januar 2020

Hallo
Dankeschön!
Zu deinem ersten Code kann ich nicht sagen da ja der komplett Teil nicht funktioniert, darum die Mappe zu testen.

Bei der Berechnung zeigt er hier einen Fehler an:
.Offset(, 1) = Offset(, -1) * Offset(, -2)

Der Steuerfuzzi · 29. Januar 2020

Mach mal die Punkte davor (habe ich in der Eile vergessen):
Code:

.Offset(, 1) = .Offset(, -1) * .Offset(, -2)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

User · 29. Januar 2020

Hallo Michael,

vielen Dank was so ein Punkt ausmacht, hast du auch noch eine Idee warum der ober Teil nicht funktioniert?

Code:

Dim i As Long
'Dim i2 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
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

aloys78 · 29. Januar 2020

Hallo,

hast du auch noch eine Idee warum der ober Teil nicht funktioniert?
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Aus meiner Sicht solltest Du noch folgende Anweisung anfügen:
Code:

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

Warum der Ausdruck CStr(cletzte)?
Es reicht cletzte

User · 29. Januar 2020

Erstmal Dankeschön:
Code:

Dim i As Long
'Dim i2 As Long
Dim cletzte As Long
Dim arrBereich As Variant
cletzte = Cells(Rows.Count, 3).End(xlUp).Row
'arrBereich = Range("C69:C" & cletzte) = arrBereich
Range("C69:C" & cletzte) = arrBereich
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
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

habe es jetzt so abgeändert, dann wird aber die komplette Einträge in ab C69 gelöscht.

Der Steuerfuzzi · 29. Januar 2020

Also bei mir läuft das durch und ersetzt die Werte korrekt:
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 i2 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*/S[0S]/*" Or arrBereich(i, 1) Like "FK-EU*/[0S]S/*" Then
arrBereich(i, 1) = Replace(Replace(Replace(arrBereich(i, 1), "/SS/", "/"), "/S0/", "/"), "/0S/", "/")
End If
Next i
Range("C69:C" & CStr(cletzte)) = arrBereich
[...]
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

User · 29. Januar 2020

Super!!! Es geht Dankeschön.

Office: Ich bekomme das Makro nicht hin

Ich bekomme das Makro nicht hin

Ich bekomme das Makro nicht hin

Ich bekomme das Makro nicht hin

Ich bekomme das Makro nicht hin

Ich bekomme das Makro nicht hin - Similar Threads - bekomme Makro

Bekomme Rahmen im Druck nicht weg

Viele Spalten untereinander in eine Spalte bekommen

Bekomme dieses Format xlCSVUTF8 nicht eingebaut

Gäste bekommen nur das Video vom Organisator der Besprechung angezeigt

Nachricht bekommen bei abgegebener Aufgabe

Hilfe ich bekomme mein Makro mit VBA nicht zum laufen :(

Makro Bugs bekomm ich einfach nicht raus :(