Office: Suchen und Summe bilden

hary · 26. Dezember 2019

Moin

Makro letzte_zelle leider bekommen ich da einen Laufzeitfehler angezeigt.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Der Fehler kommt weil durch eintragen in das Blatt, dass Worksheet_Change Ereigniss ausgefuehrt wird. Dieses unterbindet man durch: Application.EnableEvents = False
und am Ende wieder einschalten.
Bist du zufaellig Politiker?? ;-))
"Für Rundungsfehler und Fehler in der Berechnung wird keine Haftung übernommen."
Koennte auch bei Bauvorhaben der Regierung angewendet werden.
Nur sagen die es nicht.
Code:

Public Sub letzte_zelle()
Application.EnableEvents = False '--Event ausschalten
'Hier wir die letzte Zeile der Spalte C ermittelt
With Cells(Rows.Count, "C").End(xlUp).Offset(3, -1)
.Font.Bold = True
.Font.Size = 12
.Value = "Bindend sind nur die aufgeführten Rabatte auf die angegebene Preisliste."
End With
With Cells(Rows.Count, "C").End(xlUp).Offset(4, -1)
.Font.Bold = True
.Font.Size = 12
.Value = "Für Rundungsfehler und Fehler in der Berechnung wir keine Haftung übernommen."
End With
With Cells(Rows.Count, "C").End(xlUp).Offset(6, -1)
.Font.Bold = True
.Font.Size = 10
.Value = "Lieferzeit: gemäß wöchentlich erscheinender Terminliste auch abrufbar unter: "
End With
With Cells(Rows.Count, "C").End(xlUp).Offset(6, 4)
.Font.Bold = True
.Font.Size = 10
ActiveSheet.Hyperlinks.Add Anchor:=.Offset(1, -5), Address:="https://www.trox.de/downloads/b14ed3244ae40aa6/TROX_Terminliste*", TextToDisplay:="TROX Terminliste"
End With
With Cells(Rows.Count, "C").End(xlUp).Offset(8, -1)
.Font.Bold = True
.Font.Size = 10
.Value = "Bitte beachten Sie unsere allgemeinen Liefer- und Zahlungsbedingungen:"
End With
With Cells(Rows.Count, "C").End(xlUp).Offset(8, 4)
.Font.Bold = True
.Font.Size = 10
ActiveSheet.Hyperlinks.Add Anchor:=.Offset(1, 4), Address:="Allgemeine Lieferbedingungen", TextToDisplay:="TROX AGB"
End With
With Cells(Rows.Count, "C").End(xlUp).Offset(10, -1)
.Font.Bold = True
.Font.Size = 10
.Value = " Lieferkosten für fixe Lieferkosten:"
End With
With Cells(Rows.Count, "C").End(xlUp).Offset(11, -1)
.Font.Bold = True
.Font.Size = 10
.Value = " Next Day 60 von 7.00 bis 17.00 Uhr."
End With
With Cells(Rows.Count, "C").End(xlUp).Offset(12, -1)
.Font.Bold = True
.Font.Size = 10
.Value = " Next Day Zeitfenster bis 12.00 Uhr 125."
End With
With Cells(Rows.Count, "C").End(xlUp).Offset(13, -1)
.Font.Bold = True
.Font.Size = 10
.Value = " Next Day Zeitfenster bis 10.00 Uhr 150."
End With
With Cells(Rows.Count, "C").End(xlUp).Offset(14, -1)
.Font.Bold = True
.Font.Size = 10
.Value = " Fix ab dem zweiten Arbeitstag nach Versandtermin:"
End With
With Cells(Rows.Count, "C").End(xlUp).Offset(15, -1)
.Font.Bold = True
.Font.Size = 10
.Value = " Von 7.00 bis 17.00 Uhr 18."
End With
With Cells(Rows.Count, "C").End(xlUp).Offset(16, -1)
.Font.Bold = True
.Font.Size = 10
.Value = " Fixes Zeitfenster von 2 Stunden zischen 10.00 und 17.00 Uhr 100."
End With
With Cells(Rows.Count, "C").End(xlUp).Offset(18, -1)
.Font.Bold = True
.Font.Size = 10
.Value = " Wagen mit Hebebühne 150 je Lieferung."
End With
With Cells(Rows.Count, "C").End(xlUp).Offset(19, -1)
.Font.Bold = True
.Font.Size = 10
.Value = " Stadtwagen 150 je Lieferung."
End With
With Cells(Rows.Count, "C").End(xlUp).Offset(21, -1)
.Font.Bold = True
.Font.Size = 10
.Value = " Alle Mehrpreise beziehen sich immer auf eine Lieferung."
End With
Application.EnableEvents = True '--Event einschalten
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

gruss hary

User · 26. Dezember 2019

Ne, aber meine Kunden diskutieren dann gern über solche Zahlen *Smilie

Danke dir, geht super *Smilie

User · 29. Dezember 2019

Hallo hary,

leider funktioniert das mit dem Makro nicht wie gewünscht. Es kommt beim holen immer noch zu dem Fehler, aber nicht bei allen Vorlagen!? Ich habe auch versucht das ein und ausschalten einzubauen.
Könnte man das holen-umwandeln so anpassen.
Das es in Spalte C ab Zelle 29, wenn es für zwei oder drei Zellen keinen Text mehr findet.
Bis dahin löscht und den dann folgenden Text nicht löscht und davor die Positionen auf der DE** Datei einfügt.
Dann könnte man sich das Makro letzte_zelle sparen.

Aber es geht dem Ende zu 
Danke schon mal

hary · 29. Dezember 2019

Moin
Teste jetzt mal.
Code:

Sub holen_Umwandeln()
Dim wbk As Workbook
Dim lngLetzeZeile As Long, lngLetzeZeile2 As Long, i As Long
Dim offen As Boolean
Application.EnableEvents = False '--Event ausschalten
'-- holt die Daten aus der(wenn geoeffneten) Mappe "DE****"
Application.ScreenUpdating = False '--Bildschirmflackern ausschalten
'--Begrenzung der ltz. Zeile nur ab 29
lngLetzeZeile = Application.Max(29, Cells(29, "C").End(xlDown).Row)
'--kopiert Daten und fuegt diese ein, wenn Mappe "DE**" geoeffnet
For Each wbk In Workbooks '--Schleife ueber geoeffnete Mappen
If wbk.Name Like "DE*" Then '--wenn Mappenname beginnt mit DE
'--loescht Zeilen mit alten Daten
Range(Cells(29, "A"), Cells(lngLetzeZeile, "P")).EntireRow.Delete
With Workbooks(wbk.Name).Worksheets("Sheet1") '--ggf. Blattname anpassen
.Range("C1:C5").copy Cells(1, "C")
.Range("D1:D5").copy Cells(1, "D")
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
With .Range("A" & lngLetzeZeile2 + 1 & ":I" & .Cells(.Rows.Count, "C").End(xlUp).Row)
Rows("29:" & .Rows.Count + 29).Insert Shift:=xlDown '--fuegt Leerzeilen ein
.copy Cells(29, "A") '--kopiert und fuegt ein
End With
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"
Application.EnableEvents = True
Exit Sub '--Makro beenden
End If
'--umwandeln Text in Zahl
Range("H29:H" & Cells(Rows.Count, "C").End(xlUp).Row).TextToColumns Destination:=Range("H29"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'--zieht die Formeln runter
Range("J28:P28").AutoFill Destination:=Range("J28:P" & Cells(Rows.Count, "C").End(xlUp).Row), Type:=xlFillDefault
Application.EnableEvents = True
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

gruss hary

User · 29. Dezember 2019

Guten Morgen hary,

habe es schon gefunden mussten nur das ausführen der Makros tauschen.
erste letze_zelle dann Motor_Nettopreis. jetzt geht es.

Gruß und eine guten Rutsch.

Danke für alles!

Das hat sich überschnitten teste ich natürlich *Smilie

Danke.

hary · 29. Dezember 2019

Moin
Bin nicht so der religiöse Mensch,aaaber:

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

Gott sei's gepriesen und gedankt!!!!
Frohes Exceljahr 2020 und auf neue Herrausforderungen
gruss hary

User · 29. Dezember 2019

Noch ne Rückmeldung *Smilie
es funktioniert auch mit deinem letzten Makro, Problem ist nur nach jedem hohlen kommt eine weitere leere Zeile hinzu!

Gruß und danke noch mal! Ich hoffe es war eine Herausforderung für dich *wink.gif* und nicht ganz so schlimm *Smilie

Office: Suchen und Summe bilden

Suchen und Summe bilden

Suchen und Summe bilden

Suchen und Summe bilden

Suchen und Summe bilden - Similar Threads - Summe bilden

VBA Summe bilden

Excel Summe bilden wenn bestimmtes Wort und Zahl in eine Zelle vorhanden

Summe bilden, wenn eine Zahl gleich sit

Excel-Summe nur bilden, solange sich Wert nicht ändert?

Dynamische, auf Basis von Bedingungen, Summen bilden

Mit mehreren Bedingungen dann eine Summe bilden

Automatisch Summe bilden abhängig vom Wochentag