Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
824to828
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
824to828
824to828
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Kopieren mit Abfrage in Excel

Kopieren mit Abfrage in Excel
29.11.2006 09:14:23
Ronny
Hallo Excel-VBA-Profis,
ich möchte gern über einen BUTTON "als Rp1 festlegen" verschiedene Zellen aus dem Tabellenblatt "Bilanz Messwerte" ins Tabellenblatt "Rp-Vergleich" kopieren. Dabei sollen solange Datensätze (ein Datensatz = A8, B8, C8, D8, E8 und I8) aus "Bilanz Messwerte" kopiert werden bis die Bedingung:
WENN das Feld „Grenze“ leer ist, dann prüfe das Feld „StromNr.“ ob dieses auch leer ist und falls ja, dann stoppe das Kopieren der Datensätze!
erfüllt ist!
Also d.h. im Tabellenblatt "Bilanz Messwerte“ Zeile 37 der Beispieldatei ist keine „StromNr.“ und keine „Grenze“ enthalten, daher alle Datensätze Kopieren von Zeile 8 bis Zeile 36, also =28 Datensätze!
Meine Beispieldatei: https://www.herber.de/bbs/user/38578.xls
Datensatz 1 aus Tabelle "Bilanz Messwerte" in Tabelle "Rp-Vergleich":
- A8 nach E14
- B8 nach E18
- C8 nach E16
- D8 nach E15
- E8 nach E17
- I8 nach E19
Datensatz 2 aus Tabelle "Bilanz Messwerte" in Tabelle "Rp-Vergleich":
- A9 nach F14
- B9 nach F18
- C9 nach F16
- D9 nach F15
- E9 nach F17
- I9 nach F19
usw.
Des Weiteren soll nur einmal das Datum aus Zelle K4 der "Bilanz Messwerte" in die Zelle C8 und C19 der Tabelle "Rp-Vergleich" kopiert werden.
Kann mir da jemand BITTE weiterhelfen von Euch Experten? Freue mich über jede Hilfe!
Mit freundlichen Grüßen,
Ronny

14
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Kopieren mit Abfrage in Excel
29.11.2006 14:00:27
fcs
Hallo Ronny,
hier die Prozedur für den Button.
diese muss du kopieren und im VBA-Editor unter der Tabelle "Bilanz Messwerte" einfügen
Gruß
Franz

Private Sub als_Rp1_festlegen_Click()
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Dim SpalteZiel As Integer, ZeileQuelle As Long
Set wksQuelle = Me 'Worksheets("Bilanz Messwerte")
Set wksZiel = Worksheets("Rp-Vergleich")
ZeileQuelle = 8 '1. Zeile in Quelle mit Daten
SpalteZiel = 5 ' Spalte E, 1. auszufüllende Spalte in Zieltabelle
With wksQuelle
'Altdaten im Ziel löschen
wksZiel.Range(wksZiel.Cells(14, "E"), wksZiel.Cells(19, wksZiel.Columns.Count)).ClearContents
'Datum übertragen
wksZiel.Cells(8, "C") = .Cells(4, "K")
wksZiel.Cells(19, "C") = .Cells(4, "K")
'Daten Stoffströme übertragen
Do Until IsEmpty(.Cells(ZeileQuelle, "B")) And IsEmpty(.Cells(ZeileQuelle, "K"))
If Not IsEmpty(.Cells(ZeileQuelle, "B")) Then
wksZiel.Cells(14, SpalteZiel) = .Cells(ZeileQuelle, "A")
wksZiel.Cells(18, SpalteZiel) = .Cells(ZeileQuelle, "B")
wksZiel.Cells(16, SpalteZiel) = .Cells(ZeileQuelle, "C")
wksZiel.Cells(15, SpalteZiel) = .Cells(ZeileQuelle, "D")
wksZiel.Cells(17, SpalteZiel) = .Cells(ZeileQuelle, "E")
wksZiel.Cells(19, SpalteZiel) = .Cells(ZeileQuelle, "I")
ZeileQuelle = ZeileQuelle + 1
SpalteZiel = SpalteZiel + 1
If SpalteZiel = wksZiel.Columns.Count + 1 Then
MsgBox "Es können max. " & wksZiel.Columns.Count & " Spalten ausgefüllt werden."
Exit Sub
End If
Else
'2. Zeile eines Stoffstroms mit mehreren Grenzwerten,  was nun?
'do nothing?
ZeileQuelle = ZeileQuelle + 1
End If
Loop
End With
End Sub

Anzeige
AW: Kopieren mit Abfrage in Excel
29.11.2006 16:17:27
Ronny
Hi Franz,
super vielen dank für die schnelle und super funktionierende Lösung!
Hätte aber noch eine Frage die sich mir nun erst im Nachhinein gestellt hatte, da ich ja eine Hauptgröße festlegen muss in der Tabelle "Rp-Vergleich" und diese nicht doppelt eingetragen werden soll bei den andern Werten, würde ich gern eine Abfragebox für den Benutzer öffnen lassen beim ersten Klick auf den BUTTON "als Rp1 festlegen", die dann fragt "Bitte geben Sie die StromNr. Ihrer gewünschten Hauptgröße ein!". Die StromNr. muss sichtbar sein in der Spalte A der "Bilanz Messwerte", sonst Fehler Messsagebox für den Benutzer liefern wo dieser Erneut gebeten wird eine vorhandene bzw. sichtbare StromNr. anzugeben, z.B. "Es wurde keine gültige StromNr. angegeben! Bitte geben Sie eine gültige StormNr. des Systems an!"
Nach der Eingabe einer gültigen (vorhandenen bzw. sichtbaren) StromNr., soll dann die Zeile ermittelt werden wo diese StromNr. in der "Bilanz Messwerte" Tabelle steht und diese Zeile dann (analog den Datensätzen in deinen CODE oben, aber halt nur diese Zeile! also nur ein Datensatz!)in die "Rp-Vergleich" Tabelle in die Zellen F3 bis F8 kopiert werden.
Dies muss als erstes geschehen bevor ich das kopieren der anderen Werte beginne, da ich die Hauptgröße nicht zweimal kopieren möchte, d.h. dass dann nachfolgend alle Werte wie bei dem CODE von dir kopiert werden sollen, außer die vorher kopierte Hauptgröße!
Wärst du so lieb mir da nochmal Hilfestellung zu geben, wie ich dies noch bei den BUTTON "als Rp1 festlegen" unterbringen kann?
Gruß,
Ronny
Anzeige
AW: Kopieren mit Abfrage in Excel
30.11.2006 01:07:54
fcs
Hallo Ronny,
ich hab die Prozedur an die Ergänzungen angepasst
Gruss
Franz

Private Sub als_Rp1_festlegen_Click()
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Dim SpalteZiel As Integer, ZeileQuelle As Long, rngBereich As Range
Dim I As Long, Pruefung As Boolean
Set wksQuelle = Me 'Worksheets("Bilanz Messwerte")
Set wksZiel = Worksheets("Rp-Vergleich")
ZeileQuelle = 8 '1. Zeile in Quelle mit Daten
SpalteZiel = 5 ' Spalte E, 1. auszufüllende Spalte in Zieltabelle
With wksQuelle
'Belegte Zeilen in Spalte A
Set rngBereich = .Range(.Cells(ZeileQuelle, "A"), .Cells(.Rows.Count, "A").End(xlUp))
Eingabe:
StoffStrom = Val(InputBox("Bitte geben Sie die Strom-Nr. Ihrer gewünschten Hauptgröße ein!", _
"Hauptgröße eingeben"))
If StoffStrom = 0 Then Exit Sub 'Abbrechen geklickt oder nichts eingegeben
Pruefung = False
For I = 1 To rngBereich.Rows.Count
If rngBereich(I, 1) = StoffStrom Then Pruefung = True: Exit For
Next
If Pruefung = False Then
MsgBox "Es wurde keine gültige StromNr. angegeben!" & vbLf & vbLf _
& "Bitte geben Sie eine gültige StromNr. des Systems an!"
On Error GoTo 0
GoTo Eingabe
End If
'Altdaten im Ziel löschen
wksZiel.Range(wksZiel.Cells(14, "E"), wksZiel.Cells(19, wksZiel.Columns.Count)).ClearContents
'Datum übertragen
wksZiel.Cells(8, "C") = .Cells(4, "K")
wksZiel.Cells(19, "C") = .Cells(4, "K")
'Bereich mit Daten in Quelltabelle
Set rngBereich = .Range(.Cells(ZeileQuelle, "A"), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "I"))
'Hauptstrom eintragen
wksZiel.Cells(3, "F") = StoffStrom
wksZiel.Cells(7, "F") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 2, False)
wksZiel.Cells(5, "F") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 3, False)
wksZiel.Cells(4, "F") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 4, False)
wksZiel.Cells(6, "F") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 5, False)
wksZiel.Cells(8, "F") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 9, False)
'Daten Stoffströme übertragen
Do Until IsEmpty(.Cells(ZeileQuelle, "B")) And IsEmpty(.Cells(ZeileQuelle, "K"))
If Not IsEmpty(.Cells(ZeileQuelle, "B")) And StoffStrom <> .Cells(ZeileQuelle, "A") Then
wksZiel.Cells(14, SpalteZiel) = .Cells(ZeileQuelle, "A")
wksZiel.Cells(18, SpalteZiel) = .Cells(ZeileQuelle, "B")
wksZiel.Cells(16, SpalteZiel) = .Cells(ZeileQuelle, "C")
wksZiel.Cells(15, SpalteZiel) = .Cells(ZeileQuelle, "D")
wksZiel.Cells(17, SpalteZiel) = .Cells(ZeileQuelle, "E")
wksZiel.Cells(19, SpalteZiel) = .Cells(ZeileQuelle, "I")
ZeileQuelle = ZeileQuelle + 1
SpalteZiel = SpalteZiel + 1
If SpalteZiel = wksZiel.Columns.Count + 1 Then
MsgBox "Es können max. " & wksZiel.Columns.Count & " Spalten ausgefüllt werden."
Exit Sub
End If
Else
'2. Zeile eines Stoffstroms mit mehreren Grenzwerten,  was nun?
'do nothing?
ZeileQuelle = ZeileQuelle + 1
End If
Loop
End With
End Sub

Anzeige
AW: Kopieren mit Abfrage in Excel
30.11.2006 09:37:41
Ronny
SUPER Fraz, du bist echt der Beste!
Klappt sehr gut und ich kann den Quellcode bei dir auch immer schön nachvollziehen und viel draus lernen. Jedoch hab ich noch eine letzte Frag an dich. Da ich ja 2 BUTTONS habe und den andern nur anpassen muss und dieser mir ja nur den Wert2 der Hauptgröße in E9 und immer zu allen Datensätzen den Wert2 in Zeile 20 eintragen soll, hab ich einfach die zusätzlichen Einträge aus dem CODE entfernt um das kopieren von StromNr. usw. nicht doppelt ausführen zu lassen. Aber nun wollte ich beim Klick auf den BUTTON "als Rp2 festlegen" keine erneute Abfrage der StromNr. starten, da die Hauptgröße ja bereits beim BUTTON "als Rp1 festlegen" festgelegt wurde.
Wie kann ich also den CODE so abändern, dass dieser überprüft was die Hauptgröße ist, welche bei "als Rp1 festlegen" definiert wurde und dann in die Zelle F9 der "Rp-Vergleich" Tabelle mir nur den Wert einträgt und halt wieder alle Werte der Datensätze in die Zeile 20 außer die Hauptgröße die vorher ja schon in F9 eingetrageb wurde?
Darum muss ich dich leider noch bitten, da meine Versuche den CODE so umzustrukturieren, dass dies gelinkt irgendwie nicht fruchten ^^
ABER NOCHMALS VIELEN DANK BIS HIERHER, OHNE DICH HÄTTE ICH WAHRSCHEINLICH TAGE GESESSEN ^^
Gruß,
Ronny
Anzeige
AW: Kopieren mit Abfrage in Excel
30.11.2006 12:05:53
fcs
Hallo Ronny,
die Nummer des gewählten Stoffstroms holst du "einfach" aus der Zieltabelle.
Gruß
Franz

Private Sub als_Rp2_festlegen_Click()
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Dim SpalteZiel As Integer, ZeileQuelle As Long, rngBereich As Range
Dim I As Long, Pruefung As Boolean
Set wksQuelle = Me 'Worksheets("Bilanz Messwerte")
Set wksZiel = Worksheets("Rp-Vergleich")
ZeileQuelle = 8 '1. Zeile in Quelle mit Daten
SpalteZiel = 5 ' Spalte E, 1. auszufüllende Spalte in Zieltabelle
With wksQuelle
StoffStrom = wksZiel.Cells(3, "F")
'Altdaten im Ziel löschen
'...usw.
'ab hier kommste dann wohl klar
End Sub

Anzeige
AW: Kopieren mit Abfrage in Excel
30.11.2006 13:07:19
Ronny
Hi Franz,
funzt leider nicht, bekomme immer Fehlermeldung von ihm wieder, hier mal mein CODE für BUTTON "als Rp2 festlegen":

Private Sub als_Rp2_festlegen_Click()
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Dim SpalteZiel As Integer, ZeileQuelle As Long, rngBereich As Range
Dim I As Long, Pruefung As Boolean
Set wksQuelle = Me 'Worksheets("Bilanz Messwerte")
Set wksZiel = Worksheets("Rp-Vergleich")
ZeileQuelle = 8 '1. Zeile in Quelle mit Daten
SpalteZiel = 5 ' Spalte E, 1. auszufüllende Spalte in Zieltabelle
With wksQuelle
StoffStrom = wksZiel.Cells(3, "F")
Eingabe:   'RpBemerkung Abfragen
Rp2Bemerkung = InputBox("Bitte geben Sie eine kurze Bezeichnung des Referenzpunktes 2 ein!", _
"Referenzpunkt (Rp2) benennen ")
wksZiel.Cells(9, "F") = Rp2Bemerkung   'RpBemerkung eintragen
'StromNr. übernehmen, welche bei Rp1 schon festgelegt wurde
'StoffStrom = wksQuelle.Cells(3, "E")
'Datum übertragen
wksZiel.Cells(9, "C") = .Cells(4, "K")
wksZiel.Cells(20, "C") = .Cells(4, "K")
'Bereich mit Daten in Quelltabelle
Set rngBereich = .Range(.Cells(ZeileQuelle, "A"), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "I"))
'Altdaten im Ziel löschen
wksZiel.Range(wksZiel.Cells(20, "E"), wksZiel.Cells(20, wksZiel.Columns.Count)).ClearContents
'Hauptstrom eintragen
wksZiel.Cells(9, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 9, False)
'Daten Stoffströme übertragen
Do Until IsEmpty(.Cells(ZeileQuelle, "A")) And IsEmpty(.Cells(ZeileQuelle, "K"))
If Not IsEmpty(.Cells(ZeileQuelle, "A")) And StoffStrom <> .Cells(ZeileQuelle, "A") Then
wksZiel.Cells(20, SpalteZiel) = .Cells(ZeileQuelle, "I")
ZeileQuelle = ZeileQuelle + 1
SpalteZiel = SpalteZiel + 1
If SpalteZiel = wksZiel.Columns.Count + 1 Then
MsgBox "Es können max. " & wksZiel.Columns.Count & " Spalten ausgefüllt werden."
Exit Sub
End If
Else
'2. Zeile eines Stoffstroms mit mehreren Grenzwerten, dann do nothing?
ZeileQuelle = ZeileQuelle + 1
End If
Loop
End With
'Erfolgsmeldung und Abfrage ob zu Rp-Vergleich gewechselt werden soll
Dim a As String
a = MsgBox("Wollen Sie die Messdaten für Referenzpunkt 2 jetzt überprüfen?", vbYesNo, "Kopiervorgang der Rp2-Messdaten erfolgreich")
If a = vbNo Then
Worksheets("Bilanz Messwerte").Select
Else
Worksheets("Rp-Vergleich").Select
End If
End Sub

DAS ZIEL ist es halt NUR die Messwerte des Normalbet. aus "Bilanz Messwerte" in die Zellen E9 und E20 der Tabelle "Rp-Vergleich" zu kopieren und dabei wieder analog darauf achten das die Hauptgröße bei E9 und die andern in der Zeile 20 stehen. Naja und das Datum kommt auch wieder mit.
Hab dir mal meine Beispieldatei mit angepassten CODE beigelegt, vielleicht siehst so eher was ich meine!? https://www.herber.de/bbs/user/38653.xls
Freue mich schon auf deine Antwort!
Gruß,
Ronny
Anzeige
AW: Kopieren mit Abfrage in Excel
30.11.2006 14:05:43
fcs
Hallo Ronny,
kleiner Fehler große Wirkung.
Ich hatte mich bei dem Auslesen des mit Rp1 festgelegten Stoffstroms um eine Spalte vertan.
korrigiere die Zeile
StoffStrom = wksZiel.Cells(3, "F")
in
StoffStrom = wksZiel.Cells(3, "E")
Gruß
Franz
AW: Kopieren mit Abfrage in Excel
30.11.2006 14:20:11
Ronny
Hi Franz,
habs nochmal gestestet und der Button 2 funktioniert nun super!!! Dass der Fehler mir aber auch nicht aufgefallen ist SEUFZ, da probiert man hier und dort was zu ändern und dann ist es so simpel. Vielen Dank nochmal für die Buttons!
NUN muss der Rechenprozess nur noch schneller werden, hab mal die Zeit gestoppt, der brauch in meiner großen Datei (33,8MB) genau 9 Minuten, wofür er in der Beispieldatei die ich dir geschickt hatte 1 Sekunde braucht. Woran liegt dass nur und wie kann man dass beschleunigen? Kann doch keinen Benutzer zumuten 9 Minuten zu warten auf das bisschen kopieren! Vielleicht kannst mir da nochmal Hilfstellung geben Franz, bin dir wie immer sehr dankbar für deine Mühe mit mir ^^
Gruß,
Ronny
Anzeige
AW: Kopieren mit Abfrage in Excel
30.11.2006 15:28:37
Ronny
Hi Fanz,
also wenn ich die Automatische Berechnung in den xcel Optionen ausschalte gehts wieder fix, allerdings hab ich dann den Nachteil, dass die Berechnung der Referenzpunkte, also die Formeln die in der Tabelle "Rp-Vergleich" stehen nicht mehr funktionieren bzw. sich nicht aktualliesieren. Gibts denn eine Möglichkeit die Automatische Berechnung in Excel auszuschalten währedn kopiert wird und nach Abschluss des Kopiervorgangs wieder anzuschalten, dann wäre die Wartezeit etwa 8 Sekunden und akzeptabel!? Oder muss man da andere Wege gehen? Wichtig ist halt nur dass es schnell geht und der Benutzer sich mit diesen Problem nicht befassen muss bzw. nix davon merkt ^^
Hoffe du hast wieder nen super Tip für mich Franz ^^ Muss jetzt erstmal ins Krankenhaus meine Mutter besuchen, aber schaue heute Abend nochmal ins Forum, bin auf die Lösung heiß ^^
Gruß,
Ronny
Anzeige
AW: Kopieren mit Abfrage in Excel
30.11.2006 20:31:43
fcs
Hallo Ronny,
hab grad festgestellt, dass du ja in der Beispieldatei schon die kleine Sub "getMoreSpeed"
drin hast.

Sub getMoreSpeed(bDoIt As Boolean)
Application.ScreenUpdating = Not (bDoIt)
Application.EnableEvents = Not (bDoIt)
Application.Calculation = IIf(bDoIt, xlCalculationManual, xlCalculationAutomatic)
End Sub

Diese Sub kann alle Bremsen ausschalten bzw. Beschleiniger einschalten. Da in deiner Datei während des kopiervorgangs keine Aktualisierungen von Berechnungsergebnissen erforderlich sind kannst du alle 3 Optionen entsprechend schalten. Die letzte Zeile ist übrigens jenen die den Optionsschalter Berechnen Manuell/Automatisch setzt
Kopiere diese Sub auch in deine Original-Datei. Am besten in ein allgemeines Modul, kannst sie aber auch zu den Subs unter der Tabelle packen.
Mit folgender Befehlszeile aktivierst du höhere Geschwindigkeit:
Call getMoreSpeed(True)
Diese Zeile fügst du am besten jeweils hinter den Zeilen ein, mit denen du zu Beginn der Button-Makros die User-Eingaben steuerst.
Mit der Befehlszeile:
Call getMoreSpeed(False)
Setzt du den "Beschleuniger" wieder zurück. Damit wird dann auch die automatische Berechnung wieder aktiviert.
Diese Zeile fügst du vor deiner "Erfolgsmeldung" ein.
Wenn du nur die Berechnung umschalten willst, dann geht es mit diesen beiden Befehlszeilen:
Application.Calculation = xlCalculationManual 'Option Berechnen = Manuell
'...Code
Application.Calculation = xlCalculationAutomatic 'Option Berechnen = Automatisch
Zwei Tipps noch:
Baue Zeilen mit Variablendeklarationen (Dim ....) nicht mitten in Prozeduren ein. Plaziere diese jeweils an den Anfang einer Sub. Dient der Übersichtlichkeit und ist gute Programmierpraxis.
Benutze den Makrorekorder wenn du den Code für eine bestimmte Befehlsfolge/Einstellung nicht kennst. Fast alle Einstellungen, die man mit der Maus oder Tastatur machen kann, kann man auch als Makro aufzeichen. Dann hat man zumindest schon mal die Befehlssyntax. Der Rekorder spuckt meist wesentlich mehr Code als man eigentlich benötigt, da der Rekorder alle Optionen eines Dialogs aufzeichnet, auch wenn man nur eine Einstellung ändert. Da muss man dann den Code ggf. wieder etwas aufräumen.
Gruß
Franz
Gruss
Franz
Anzeige
AW: Kopieren mit Abfrage in Excel
01.12.2006 11:05:11
Ronny
Hallo Franz,
und wieder eine super und leicht verständliche Hilfe von dir die ich in Zukunft bei all meinen VBA Schritten berücksichtigen werde, vielen DANK!!!
Wollte nun noch den CODE so optimieren, dass er berücksichtigt bei der Messwertübernahme, dass falls kein Wert bei Normalbet. steht (weil z.B. dies eine Probenahmestelle ist und der Wert bei Infra oder Labor steht), dieser dann erst schaut ob ein Wert bei Infra steht und falls nein, dann schaut ob ein Wert bei Labor steht und falls dies auch nicht der Fall ist am besten die ganze Messung nicht mit zum Vergleich heranzieht.
Hab dies so in VBA umgesetzt:
'Abfrage ob 1.Normalbet., 2.Infra- od. 3.Laborwert vorhanden ist und wenn ja dann erst 1., dann 2. und als letztes 3. einsetzen
If Not IsEmpty(.Cells(ZeileQuelle, "I")) Then
wksZiel.Cells(19, SpalteZiel) = .Cells(ZeileQuelle, "I")
Else
If Not IsEmpty(.Cells(ZeileQuelle, "G")) Then
wksZiel.Cells(19, SpalteZiel) = .Cells(ZeileQuelle, "G")
Else
If Not IsEmpty(.Cells(ZeileQuelle, "H")) Then
wksZiel.Cells(19, SpalteZiel) = .Cells(ZeileQuelle, "H")
Else
wksZiel.Cells(19, SpalteZiel) = .Cells(ZeileQuelle, "BL") 'meine Notlösung war einfach hier eine Leere Zelle anzusteuern, weis ist nicht gut =(
End If
End If
End If
Leider ist meine Lösung nicht gut, denn die funktioniert nicht, weis aber nich warum! Naja und ich habe auch keinen Plan wie ich die Aussage formuliere, dass der ganze Datensatz zum Messwert nicht mit kopiert werden soll!
Zusätzlich würde ich immer gern in Zeile 13 wieder beginnend in Spalte E der "Rp-Vergleich" Tabelle immer die Bezeichnung für den jeweiligen Wert eintragen lassen, also Normalbet., Infrawert oder Laborwert, d.h. wenn es keinen Normalbet.-wert gibt und er dann den Infrawert kopiert soll er anstatt Normalbet. einfach Infrawert in die Zeile 13 der "Rp-Vergleich" Tabelle eintragen. Naja und bei der Hauptgröße eintragen muss ich auch aufpassen ob Normalbet. usw ^^
Hast du nochmal eine rettende Idee für mich? BITTE! Ist auch die letzte Optimierung zum "Rp-Vergleich" ***Versprochen***
Mfg,
Ronny
AW: Kopieren mit Abfrage in Excel
01.12.2006 15:21:50
fcs
Hallo Ronny,
dass deine If-Prüfungen nicht funktionieren liegt daran, dass die Zellen nicht leer sind. In den Zellen steht jeweils "(Leer)", das du durch die bedingte Formatierung "unsichbar" gemacht hast.
Ich hab deine Wünsche nochmals eingearbeitet. Dabei waren insbesondere an der Rp2-Prozedur grundlegende Änderungen nötig, um zu berücksichtigen, dass in der Rp1-Prozedur alle Stromnummern weggelassen werden, für die keine Werte in den Spalten G, H und I eingetragen sind.
Deshalb hier nochmals die komplett überarbeiteten Prozeduren.
Ich hoffe, dass ich bei den verschiedenen If-Abfragen alle Sonderfälle getroffen hab und die Prozeduren ohne Debug-Abbruch durchlaufen.
Gruß
Franz

Private Sub als_Rp1_festlegen_Click()
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Dim SpalteZiel As Integer, ZeileQuelle As Long, rngBereich As Range
Dim I As Long, Pruefung As Boolean
Set wksQuelle = Me 'Worksheets("Bilanz Messwerte")
Set wksZiel = Worksheets("Rp-Vergleich")
ZeileQuelle = 8 '1. Zeile in Quelle mit Daten
SpalteZiel = 5 ' Spalte E, 1. auszufüllende Spalte in Zieltabelle
With wksQuelle
'Belegte Zeilen in Spalte A
Set rngBereich = .Range(.Cells(ZeileQuelle, "A"), .Cells(.Rows.Count, "A").End(xlUp))
Eingabe:   'RpBemerkung Abfragen
Rp1Bemerkung = InputBox("Bitte geben Sie eine kurze Bezeichnung des Referenzpunktes 1 ein!", _
"Referenzpunkt (Rp1) benennen ")
wksZiel.Cells(8, "F") = Rp1Bemerkung   'RpBemerkung eintragen
'StromNr. Abfragen
Eingabe2:
StoffStrom = Val(InputBox("Bitte geben Sie die StromNr. Ihrer gewünschten Hauptgröße ein!", _
"Hauptgröße definieren durch Eingabe der StromNr."))
If StoffStrom = 0 Then Exit Sub 'Abbrechen geklickt oder nichts eingegeben
Pruefung = False
For I = 1 To rngBereich.Rows.Count
If rngBereich(I, 1) = StoffStrom Then Pruefung = True: Exit For
Next
If Pruefung = False Then
MsgBox "Es wurde keine gültige StromNr. angegeben!" & vbLf & vbLf _
& "Bitte geben Sie eine gültige StromNr. des Systems an!", vbCritical
On Error GoTo 0
GoTo Eingabe2
End If
Call getMoreSpeed(True)
'Altdaten im Ziel löschen
wksZiel.Range(wksZiel.Cells(13, "E"), wksZiel.Cells(19, wksZiel.Columns.Count)).ClearContents
'Datum übertragen
wksZiel.Cells(8, "C") = .Cells(4, "K")
wksZiel.Cells(19, "C") = .Cells(4, "K")
'Bereich mit Daten in Quelltabelle
Set rngBereich = .Range(.Cells(ZeileQuelle, "A"), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "I"))
'Hauptstrom eintragen
'Abfrage ob 1.Normalbet., 2.Infra- od. 3.Laborwert vorhanden ist und wenn ja dann erst 1., dann 2. und als letztes 3. einsetzen
'Zeile 8 in Zieltabelle ausfüllen
If Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 9, False) <> "(Leer)" Then
'Normalbetrieb
wksZiel.Cells(2, "F") = "Normalbetrieb"
wksZiel.Cells(8, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 9, False)
Else
If Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 7, False) <> "(Leer)" Then
'Infra-Wert
wksZiel.Cells(2, "F") = "Infrawert"
wksZiel.Cells(8, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 7, False)
Else
If Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 8, False) <> "(Leer)" Then
'LaborWert
wksZiel.Cells(2, "F") = "Laborwert"
wksZiel.Cells(8, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 8, False)
Else
If MsgBox("Es ist für den gewählten Strom kein Eintrag in den Spalten Betrieb, Infrawert oder Laborwert vorhanden!", _
vbOKCancel, "Rp1 Hauptstrom-Daten übertragen") = vbCancel Then
Exit Sub
End If
End If
End If
End If
wksZiel.Cells(3, "E") = StoffStrom
wksZiel.Cells(7, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 2, False)
wksZiel.Cells(5, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 3, False)
wksZiel.Cells(4, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 4, False)
wksZiel.Cells(6, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 5, False)
'Daten Stoffströme übertragen
Do Until IsEmpty(.Cells(ZeileQuelle, "A")) And IsEmpty(.Cells(ZeileQuelle, "K"))
If Not IsEmpty(.Cells(ZeileQuelle, "A")) And StoffStrom <> .Cells(ZeileQuelle, "A") Then
'Abfrage ob 1.Normalbet., 2.Infra- od. 3.Laborwert vorhanden ist und wenn ja dann erst 1., dann 2. und als letztes 3. einsetzen
'Zeile 19 in Zieltabelle ausfüllen
If .Cells(ZeileQuelle, "I") <> "(Leer)" Then
'Normalbetrieb
wksZiel.Cells(13, SpalteZiel) = "Normalbetrieb"
wksZiel.Cells(19, SpalteZiel) = .Cells(ZeileQuelle, "I")
Else
If .Cells(ZeileQuelle, "G") <> "(Leer)" Then
'Infra-Wert
wksZiel.Cells(13, SpalteZiel) = "Infrawert"
wksZiel.Cells(19, SpalteZiel) = .Cells(ZeileQuelle, "G")
Else
If .Cells(ZeileQuelle, "H") <> "(Leer)" Then
'LaborWert
wksZiel.Cells(13, SpalteZiel) = "Laborwert"
wksZiel.Cells(19, SpalteZiel) = .Cells(ZeileQuelle, "H")
Else
'kein Eintrag in den Spalten I, G oder H --> Zeile überspringen
ZeileQuelle = ZeileQuelle + 1
GoTo NaechsteZeile
End If
End If
End If
wksZiel.Cells(14, SpalteZiel) = .Cells(ZeileQuelle, "A")
wksZiel.Cells(18, SpalteZiel) = .Cells(ZeileQuelle, "B")
wksZiel.Cells(16, SpalteZiel) = .Cells(ZeileQuelle, "C")
wksZiel.Cells(15, SpalteZiel) = .Cells(ZeileQuelle, "D")
wksZiel.Cells(17, SpalteZiel) = .Cells(ZeileQuelle, "E")
ZeileQuelle = ZeileQuelle + 1
SpalteZiel = SpalteZiel + 1
If SpalteZiel = wksZiel.Columns.Count + 1 Then
MsgBox "Es können max. " & wksZiel.Columns.Count & " Spalten ausgefüllt werden."
Exit Sub
End If
Else
'2. Zeile eines Stoffstroms mit mehreren Grenzwerten, dann do nothing?
ZeileQuelle = ZeileQuelle + 1
End If
NaechsteZeile:
Loop
End With
Call getMoreSpeed(False)
'Erfolgsmeldung und Abfrage ob zu Rp-Vergleich gewechselt werden soll
Dim a As String
a = MsgBox("Wollen Sie die Messdaten für Referenzpunkt 1 jetzt überprüfen?", vbYesNo, "Kopiervorgang der Rp1-Messdaten erfolgreich")
If a = vbNo Then
Worksheets("Bilanz Messwerte").Select
Else
Worksheets("Rp-Vergleich").Select
End If
End Sub
Private Sub als_Rp2_festlegen_Click()
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Dim SpalteZiel As Integer, ZeileQuelle As Long, rngBereich As Range
Dim I As Long, Pruefung As Boolean
Set wksQuelle = Me 'Worksheets("Bilanz Messwerte")
Set wksZiel = Worksheets("Rp-Vergleich")
ZeileQuelle = 8 '1. Zeile in Quelle mit Daten
SpalteZiel = 5 ' Spalte E, 1. auszufüllende Spalte in Zieltabelle
With wksQuelle
Eingabe:   'RpBemerkung Abfragen
Rp2Bemerkung = InputBox("Bitte geben Sie eine kurze Bezeichnung des Referenzpunktes 2 ein!", _
"Referenzpunkt (Rp2) benennen ")
wksZiel.Cells(9, "F") = Rp2Bemerkung   'RpBemerkung eintragen
Call getMoreSpeed(True)
'StromNr. übernehmen, welche bei Rp1 schon festgelegt wurde
StoffStrom = wksZiel.Cells(3, "E")
'Datum übertragen
wksZiel.Cells(9, "C") = .Cells(4, "K")
wksZiel.Cells(20, "C") = .Cells(4, "K")
'Bereich mit Daten in Quelltabelle
Set rngBereich = .Range(.Cells(ZeileQuelle, "A"), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "I"))
'Altdaten im Ziel löschen
wksZiel.Range(wksZiel.Cells(20, "E"), wksZiel.Cells(20, wksZiel.Columns.Count)).ClearContents
wksZiel.Range(wksZiel.Cells(23, "E"), wksZiel.Cells(23, wksZiel.Columns.Count)).ClearContents
'Hauptstrom eintragen
'Abfrage ob 1.Normalbet., 2.Infra- od. 3.Laborwert vorhanden ist und wenn ja dann erst 1., dann 2. und als letztes 3. einsetzen
'Zeile 9 in Zieltabelle ausfüllen
If Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 9, False) <> "(Leer)" Then
'Normalbetrieb
wksZiel.Cells(10, "F") = "Normalbetrieb"
wksZiel.Cells(9, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 9, False)
Else
If Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 7, False) <> "(Leer)" Then
'Infra-Wert
wksZiel.Cells(10, "F") = "Infrawert"
wksZiel.Cells(9, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 7, False)
Else
If Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 8, False) <> "(Leer)" Then
'LaborWert
wksZiel.Cells(10, "F") = "Laborwert"
wksZiel.Cells(9, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 8, False)
Else
If MsgBox("Es ist für den gewählten Strom kein Eintrag in den Spalten Betrieb, Infrawert oder Laborwert vorhanden!", _
vbOKCancel, "Rp2 Hauptstrom-Daten übertragen") = vbCancel Then
Exit Sub
End If
End If
End If
End If
'Rp2-Daten für StoffstromNummern aus Rp1-Eintrag in Zieltabelle einlesen
Do Until IsEmpty(wksZiel.Cells(14, SpalteZiel))
'Prüfen ob die StromNummer in der Quelle vorhanden ist
'Bereich mit Stromnummern in Spalte A
Set rngBereich = .Range(.Cells(ZeileQuelle, "A"), .Cells(.Rows.Count, "A").End(xlUp))
Pruefung = False
For I = 1 To rngBereich.Rows.Count
If rngBereich(I, 1) = wksZiel.Cells(14, SpalteZiel) Then Pruefung = True: Exit For
Next
If Pruefung = False Then
'StromNummer nicht vorhanden
wksZiel.Cells(23, SpalteZiel) = "Keine StromNr"
wksZiel.Cells(20, SpalteZiel) = "Keine StromNr"
Else
'Abfrage ob 1.Normalbet., 2.Infra- od. 3.Laborwert vorhanden ist und wenn ja dann erst 1., dann 2. und als letztes 3. einsetzen
'Zeile 20 in Zieltabelle ausfüllen, in Spalte 23 wird eingetragen wo Wert herkommt
'Bereich mit Daten in Quelltabelle
Set rngBereich = .Range(.Cells(ZeileQuelle, "A"), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "I"))
If Application.WorksheetFunction.VLookup(wksZiel.Cells(14, SpalteZiel), rngBereich, 9, False) <> "(Leer)" Then
'Normalbetrieb
wksZiel.Cells(23, SpalteZiel) = "Normalbetrieb"
wksZiel.Cells(20, SpalteZiel) = Application.WorksheetFunction.VLookup(wksZiel.Cells(14, SpalteZiel), rngBereich, 9, False)
Else
If Application.WorksheetFunction.VLookup(wksZiel.Cells(14, SpalteZiel), rngBereich, 7, False) <> "(Leer)" Then
'Infra-Wert
wksZiel.Cells(23, SpalteZiel) = "Infrawert"
wksZiel.Cells(20, SpalteZiel) = Application.WorksheetFunction.VLookup(wksZiel.Cells(14, SpalteZiel), rngBereich, 7, False)
Else
If Application.WorksheetFunction.VLookup(wksZiel.Cells(14, SpalteZiel), rngBereich, 8, False) <> "(Leer)" Then
'LaborWert
wksZiel.Cells(23, SpalteZiel) = "Laborwert"
wksZiel.Cells(20, SpalteZiel) = Application.WorksheetFunction.VLookup(wksZiel.Cells(14, SpalteZiel), rngBereich, 8, False)
Else
'kein Wert vorhanden
wksZiel.Cells(23, SpalteZiel) = "KeinWert"
wksZiel.Cells(20, SpalteZiel) = "KeinWert"
End If
End If
End If
End If
SpalteZiel = SpalteZiel + 1
If SpalteZiel = wksZiel.Columns.Count + 1 Then
MsgBox "Es können max. " & wksZiel.Columns.Count & " Spalten ausgefüllt werden."
Exit Do
End If
Loop
End With
Call getMoreSpeed(False)
'Erfolgsmeldung und Abfrage ob zu Rp-Vergleich gewechselt werden soll
Dim a As String
a = MsgBox("Wollen Sie die Messdaten für Referenzpunkt 2 jetzt überprüfen?", vbYesNo, "Kopiervorgang der Rp2-Messdaten erfolgreich")
If a = vbNo Then
Worksheets("Bilanz Messwerte").Select
Else
Worksheets("Rp-Vergleich").Select
End If
End Sub
Sub getMoreSpeed(bDoIt As Boolean)
Application.ScreenUpdating = Not (bDoIt)
Application.EnableEvents = Not (bDoIt)
Application.Calculation = IIf(bDoIt, xlCalculationManual, xlCalculationAutomatic)
End Sub

AW: Kopieren mit Abfrage in Excel
04.12.2006 11:36:08
Ronny
Hallo Franz,
also der erste Button klappt gut aber der zweite liefert mir eine Fehlermeldung zurück. Hab zwar die Form etwas umgeändert von den Zieltabellen aber im Grunde kann es daran nicht liegen. Hier meine neue Datei mit CODE usw., schau bitte mal rein was da nicht stimmt? https://www.herber.de/bbs/user/38710.xls
Änderungen von mir:
- Zeilen und Spaltenbezüge (hab ich aber überall schon angepasst)
- Kopiere das Datum nur noch einmal (auch angepasst)
- die Bezeichnung ob der Wert Nomalbet., Infrawert oder Laborwert ist, entscheidet sich bereits bei Button 1 "als Rp1 festlegen" und muss daher nicht bei Button 2 "als Rp2 festlegen" wieder eingetragen werden, deshalb hab ichs rausgenommen beim Button 2
Hinweise:
- Wenn der Wert bei Button 1 "als Rp1 festlegen" ein Nomalbet., Infrawert oder Laborwert ist, dann ist der Wert bei Button 2 "als Rp2 festlegen" die selbe MesWert-Art! Es ändert sich beim Vergleich de Referenzpunkte nur das Datum und die Meswerte!
Was ich noch für sinnvol halten würde:
- Eine Überprüfung ob bei Button 1 "als Rp1 festlegen" eine Hauptgröße festgelegt wurde (um zu ermitteln ob überhaupt Rp1 schon festgelegt wurde) und wenn nein, dann Abbruch-Hinweismeldung "Es wurde noch kein Referenzpunkt 1 festgelegt! Bitte erst den Referenzpunkt 1 für den Vergleich festlegen!" bringen. So würde man sicher gehen, dass auch StromNr. eingetragen sind in der Tabelle "Rp-Vergleich" und es ist auch der logische Schritt, den Rp1 vorher festzulegen.
- Ein Button in der Tabelle "Rp-Vergleich", welcher alle Einträge in den ZielZellen von BUTTON 1 und BUTTON 2 löscht, und vor dem löschen eine Abfrage gestartet wird: "Alle Angaben vom Rp1 und Rp2-Vergleich werden gelöscht! Soll der Vergleich von Rp1 und Rp2 vor dem löschen in einer seperaten Excel-Tabelle gespeichert werden?" und wenn ja dann einfach das Tabellenblatt "Rp-Vergleich" abspeichern lassen und vorher noch Name und Zielspeicherot auswählen lassen.
Bin dir wie immer sehr dankbar für deine Unterstützung!!!
Gruß,
Ronny
AW: Kopieren mit Abfrage in Excel
30.11.2006 14:10:43
Ronny
Hi Franz,
ich habe gerade die "Rp-Vergleich" Tabelle in meine größere Datei übernommen und den Quellcode sowie die Buttons dazu. Die Datei ist 33,8 MB groß, da dort viele Messdaten abgespeichert sind. Wenn ich nun den Button "als Rp1 festlegen" in meiner großen Datei starte und etwa auch nur 30 Messwerte zum kopieren im Privotbericht anzeigen lasse, dann braucht der Kopiervorgang nicht mehr 1 Sekunde sondern 15 Minuten, wie kann dass sein? Was macht Excel in der zeit noch zusätzlich außer den Kopiervorgang den ich eingeleitet habe? Oder muss man noch was am Quellcode ändern?
Gruß vom ratlosen,
Ronny ^^

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige