Registriert seit: 14.04.2014
Version(en): 2003, 2007
Hallo vivi,
ich habe mal eine ganz banale Lösung ohne jede Fehlerabfrage erstellt.
Teste es in einer Kopie Deiner Datei.
Folgende Vorgehensweise:
-Du markierst die zu übertragenden Zellen innerhalb einer Zeile.
-Dann machst Du einen Rechtsklick innerhalb des markierten Bereichs
Mit dem Rechtsklick wird das Makro gestartet.
Das Ganze funktioniert im Bereich der Zeilen 7:19 wie im Code in der Zeile mit Kommentar ersichtlicht.
Wegen Feinheiten oder Besonderheiten fragst Du bitte erneut nach.
Wenn Dir das mit dem Rechtsklick nicht passt, müste man es über eine Schaltfläche machen.
Unten der Code, welcher in das Codefenster der Tabelle "Personal" eingefügt werden muss
(Rechtsklick auf den Tabellenreiter -> Code anzeigen wählen und in das große freie Fenster hinein kopieren)
Code: Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim rngZeilen As Range
Dim lngAnfang As Long
Dim lngEnde As Long
Dim lngLeseZeile As Long
Dim lngSchreibZeile As Long
Set rngZeilen = Rows("7:19") 'hier die Zeilenzahlen anpassen in denen die Eintrageungen bzw.Zellen markiert werden zum Übertragen
If Intersect(rngZeilen, Target) Is Nothing Then Exit Sub
Cancel = True
lngAnfang = Selection.Column
lngEnde = lngAnfang + Selection.Columns.Count - 1
lngLeseZeile = Selection.Row
With Sheets("Gespräche")
lngSchreibZeile = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(lngSchreibZeile, 1) = Cells(lngLeseZeile, 1)
.Cells(lngSchreibZeile, 2) = Cells(5, lngAnfang)
.Cells(lngSchreibZeile, 3) = Cells(5, lngEnde)
.Cells(lngSchreibZeile, 4) = Cells(lngLeseZeile, lngAnfang)
.Cells(lngSchreibZeile, 5) = Date
End With
MsgBox "Daten übertragen"
End Sub
Gruß Atilla
Registriert seit: 29.09.2015
Version(en): 2030,5
14.01.2017, 18:24
(Dieser Beitrag wurde zuletzt bearbeitet: 14.01.2017, 18:24 von snb.)
oder:
Code: Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If not Intersect(Rows("7:19"), Target) Is Nothing Then
Cancel = True
Sheets("Gespräche").Cells(Rows.Count, 1).End(xlUp).offset(1).resize(,5)=array(Cells(target.row, 1), cells(5,target.column +target.columns.count-1),target.value,date)
end if
End Sub
Registriert seit: 14.04.2014
Version(en): 2003, 2007
14.01.2017, 18:42
(Dieser Beitrag wurde zuletzt bearbeitet: 14.01.2017, 18:46 von atilla.)
Hallo snb,
gut, dass du zu meiner Anfängerzeit bei meinen Fragen, nicht geantwortet hast.
Ich weiß nicht, ob ich noch Spaß entwickelt hätte mich mit VBA zu beschäftigen.
Zu meiner Anfangszeit, hatte ich strahlende Augen und ein breit grinsendes Gesicht :19: , wenn ich ein Code hatte, der das machte was ich wollte.
Das waren Codes mit tausenden Selects. Und der größte Spaß war Excel zuzusehen, wie es die einzelnen Selects ausführte. (diesen Spaß gönne ich mir heimlich immer noch) :25:
Diesen Spaß hätte ich nie erfahren, wenn es nach Dir ginge. :@
Gruß Atilla
Registriert seit: 29.09.2015
Version(en): 2030,5
14.01.2017, 21:18
(Dieser Beitrag wurde zuletzt bearbeitet: 14.01.2017, 21:19 von snb.)
@Att
Du darfst meinerseits immer auf Ratschlägen verzichten, eben meine ;)
Ich möchte nur Alternative zeigen.
Registriert seit: 10.04.2014
Version(en): Office 2019
(14.01.2017, 13:03)RPP63 schrieb: Moin Vivian!
Informationen zum Thema Crossposting (anklickbarer Link).
Nachbarforum
Gruß Ralf
Hi, das geht ja gut los... ;-(
Gruß Jörg
ich muss mich erst wieder ganz langsam heran robben. Also bitte ich um Nachsicht
"Wer immer tut, was er schon kann, bleibt immer das, was er schon ist." - Henry Ford
Registriert seit: 11.04.2014
Version(en): '97 bis 2016; 365
14.01.2017, 21:29
(Dieser Beitrag wurde zuletzt bearbeitet: 14.01.2017, 21:31 von Käpt'n Blaubär.)
Hallo Atilla,
Deine Aussage in dem Posting #13 kann ich sehr gut nachvollziehen weil es mir ganz genau so geht.
Zitat:Diesen Spaß hätte ich nie erfahren, wenn es nach Dir ginge.
Um mir diesen kleinen Spaß zur Entspannung bequem gönnen zu können gibt es in meinen
Programmen die Zeile Application.ScreenUpdating = False, die sich schnell und problemlos
umschalten läßt.
Ich freue mich, festzustellen, daß nicht nur ich so verrückt bin, an dieser "Hüpferei" Spaß zu haben.
________________________________________________________________________
wer aufgibt, ohne es versucht zu haben, gibt einfach nur auf!
Grüße aus Norderstedt, Peter
Registriert seit: 14.04.2014
Version(en): 2003, 2007
Hallo Peter,
danke für Deine Einlassung und Unterstützung.
Fairer Weise muss ich aber sagen, ohne solche Codes, wie von snb, hätte man auch den Spaß mit dem Arbeiten an und mit manchen Projekten verloren.
Mich machen diese Codes schon etwas an.
Gruß Atilla
Registriert seit: 11.04.2014
Version(en): '97 bis 2016; 365
Hallo Atilla,
Zitat:Fairer Weise muss ich aber sagen, ohne solche Codes, wie von snb, hätte man auch den Spaß mit dem Arbeiten an und mit manchen Projekten verloren.
Mich machen diese Codes schon etwas an.
ich habe snb in der Vergangenheit mehrmals darauf hingewiesen, daß ich seine Codes wahnsinnig effektiv finde
und ich leider sehr weit davon weg bin, so programmieren, wie er es kann. Ich fürchte, diese Stufe der Programmierung
in diesem Leben auch nicht mehr erreichen zu können.
Einem Anfänger allerdings, so behaupte ich, bleibt nichts weiter übrig, als die Codes wie sie geliefert werden einzubauen,
sich zu freuen, daß sein Problem gelöst ist und um Himmelswillen nicht zu versuchen, den Code zu verändern.
Alles in Allem, ich finde snb's Arbeiten wirklich beneidenswert gut.
________________________________________________________________________
wer aufgibt, ohne es versucht zu haben, gibt einfach nur auf!
Grüße aus Norderstedt, Peter
Registriert seit: 14.01.2017
Version(en): 2010
(14.01.2017, 18:05)atilla schrieb: Hallo vivi,
ich habe mal eine ganz banale Lösung ohne jede Fehlerabfrage erstellt.
Teste es in einer Kopie Deiner Datei.
Folgende Vorgehensweise:
-Du markierst die zu übertragenden Zellen innerhalb einer Zeile.
-Dann machst Du einen Rechtsklick innerhalb des markierten Bereichs
Mit dem Rechtsklick wird das Makro gestartet.
Das Ganze funktioniert im Bereich der Zeilen 7:19 wie im Code in der Zeile mit Kommentar ersichtlicht.
Wegen Feinheiten oder Besonderheiten fragst Du bitte erneut nach.
Wenn Dir das mit dem Rechtsklick nicht passt, müste man es über eine Schaltfläche machen.
Unten der Code, welcher in das Codefenster der Tabelle "Personal" eingefügt werden muss
(Rechtsklick auf den Tabellenreiter -> Code anzeigen wählen und in das große freie Fenster hinein kopieren)
Code: Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim rngZeilen As Range
Dim lngAnfang As Long
Dim lngEnde As Long
Dim lngLeseZeile As Long
Dim lngSchreibZeile As Long
Set rngZeilen = Rows("7:19") 'hier die Zeilenzahlen anpassen in denen die Eintrageungen bzw.Zellen markiert werden zum Übertragen
If Intersect(rngZeilen, Target) Is Nothing Then Exit Sub
Cancel = True
lngAnfang = Selection.Column
lngEnde = lngAnfang + Selection.Columns.Count - 1
lngLeseZeile = Selection.Row
With Sheets("Gespräche")
lngSchreibZeile = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(lngSchreibZeile, 1) = Cells(lngLeseZeile, 1)
.Cells(lngSchreibZeile, 2) = Cells(5, lngAnfang)
.Cells(lngSchreibZeile, 3) = Cells(5, lngEnde)
.Cells(lngSchreibZeile, 4) = Cells(lngLeseZeile, lngAnfang)
.Cells(lngSchreibZeile, 5) = Date
End With
MsgBox "Daten übertragen"
End Sub
Danke Euch für Eure Mühen
@Atilla
Deine Lösung funktioniert wunderbar, allerdings blockiert diese Lösung mir die rechte Maustaste um auch z.B. die Kommentar-Funktion einfügen zu können.
Ich brauche also die rechte Maustaste und kann diese nicht nutzen, um die Daten zu übertragen ... ginge das auch als "normales Makro" um dieses auf eine Tastenkombination zu legen ?
Mit dem Makro von snb erscheint beim Übertragen folgendes:
Name von bis Übertragener Grund Gesprächstermin
Mitarbeiter 8 05.01.2017 15.01.2017 #NV
Registriert seit: 14.04.2014
Version(en): 2003, 2007
Hallo vivi,
damit meine Variante sich mit etwas Professionalität von snb's abhebt, habe ich jetzt minimale Fehlerabfragen eingebaut. :05:
Unten stehendes Makro wieder in das Codefenster der Tabelle kopieren und eine Tastenkombi zuweisen.
Code: Sub übertragen()
Dim i As Long, x As Long
Dim rngZeilen As Range
Dim lngAnfang As Long
Dim lngEnde As Long
Dim lngLeseZeile As Long
Dim lngSchreibZeile As Long
Dim vntA
vntA = Array("U", "X", "K")
Set rngZeilen = Rows("7:19") 'hier die Zeilenzahlen anpassen in denen die Eintrageungen bzw.Zellen markiert werden zum Übertragen
If Intersect(rngZeilen, Selection) Is Nothing Then
MsgBox "Auswahl befindet sich nicht im zulässigen Bereich. "
Exit Sub
End If
For i = LBound(vntA) To UBound(vntA)
x = Application.Max(x, Application.CountIf(Selection, vntA(i)))
Next i
If x <> Selection.Columns.Count Then
MsgBox "Die Auswahl ist nicht konsistent!"
Exit Sub
End If
lngAnfang = Selection.Column
lngEnde = lngAnfang + Selection.Columns.Count - 1
lngLeseZeile = Selection.Row
With Sheets("Gespräche")
lngSchreibZeile = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(lngSchreibZeile, 1) = Cells(lngLeseZeile, 1)
.Cells(lngSchreibZeile, 2) = Cells(5, lngAnfang)
.Cells(lngSchreibZeile, 3) = Cells(5, lngEnde)
.Cells(lngSchreibZeile, 4) = Cells(lngLeseZeile, lngAnfang)
.Cells(lngSchreibZeile, 5) = Date
End With
MsgBox "Daten wurden übertragen"
End Sub
Und snb's Code ginge so:
Code: Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Rows("7:19"), Target) Is Nothing Then
Cancel = True
Sheets("Gespräche").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 5) = Array(Cells(Target.Row, 1), Cells(5, Target.Column), Cells(5, Target.Column + Target.Columns.Count - 1), Target.Text, Date)
End If
End Sub
@snb
Beachte: Target.Text, da ja mehrere Zellen ausgewählt werden können. Komisch dass der Code da keinen Fehler verursacht hat.
Gruß Atilla
|