Automatisieren

[atilla]

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

[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

[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. :@

[snb]

@Att

Du darfst meinerseits immer auf Ratschlägen verzichten, eben meine ;)

Ich möchte nur Alternative zeigen.

[Jockel]

Moin Vivian!
Informationen zum Thema Crossposting (anklickbarer Link).
Nachbarforum

Gruß Ralf

Hi, das geht ja gut los... ;-(

[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.

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.

[atilla]

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.

[Käpt'n Blaubär]

Hallo Atilla,

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.

[VivianL]

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

[atilla]

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.