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
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. :@
@Att
Du darfst meinerseits immer auf Ratschlägen verzichten, eben meine ;)
Ich möchte nur Alternative zeigen.
(14.01.2017, 13:03)RPP63 schrieb: [ -> ]Moin Vivian!
Informationen zum Thema Crossposting (anklickbarer Link).
Nachbarforum
Gruß Ralf
Hi, das geht ja gut los... ;-(
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.
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.
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.
(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
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.