Zeile in andere Tabelle kopieren

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean) If Not Intersect(Target, Range("B2:K65000")) Is Nothing Then Cancel = True MsgBox "jetzt kopieren" End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean) If Not Intersect(Target, Range("B2:K65000")) Is Nothing Then Cancel = True Worksheets("Information").Range("A5:A14") = Application.Transpose(Range(Cells(Target.Row, 2), Cells(Target.Row, 11)).Value) End If End Sub

Private Sub Rg_Vorlage_kopieren() Dim wb As Workbook Dim b As Boolean Dim i For Each wb In Application.Workbooks If wb.name Like "__Rg_Vorlage_kopiere.xlsm" Then b = True Exit For End If Next wb ' Stop If Not b Then ' MsgBox "nix gefunden" Exit Sub End If wb.Activate Dim ze ze = ActiveSheet.name wb.Worksheets(ze).Range("K12:K20") = Application.Transpose(Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, 10))) Application.ScreenUpdating = True End Sub

Private Sub Rg_Vorlage_kopieren() Dim wb As Workbook Dim thiswb As Workbook Dim b As Boolean Dim i&, ze Set thiswb = ThisWorkbook i = ActiveCell.Row ze = ActiveSheet.Name For Each wb In Application.Workbooks If wb.Name Like "__Rg_Vorlage_kopiere.xlsm" Then b = True Exit For End If Next wb ' Stop If Not b Then ' MsgBox "nix gefunden" Exit Sub End If With thiswb wb.Worksheets(ze).Range("K12:K20") = Application.Transpose(.Range(.Cells(i, 2), .Cells(i, 10))) End With Application.ScreenUpdating = True End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim wb As Workbook Dim b As Boolean Dim i For Each wb In Application.Workbooks If wb.name Like "__Rechnungs-Programm Vers.*.xlsm" Then b = True Exit For End If Next wb If Not b Then ' MsgBox "nix gefunden" Exit Sub End If wb.Activate wb.Activate Dim ze ze = ActiveSheet.name For i = 0 To 5 wb.Worksheets(ze).Range("K12").Cells(i + 1, 1) = ListBox1.Column(i) Next i 'Unload Me End Sub

Private Sub Rg_Vorlage_kopieren() Dim wb As Workbook Dim thiswb As Workbook Dim b As Boolean Dim i&, ze Set thiswb = ThisWorkbook i = ActiveCell.Row ze = ActiveSheet.name For Each wb In Application.Workbooks If wb.name Like "__Rechnungs-Programm Vers.*.xlsm" Then b = True Exit For End If Next wb ' Stop If Not b Then ' MsgBox "nix gefunden" Exit Sub End If With ActiveSheet wb.Worksheets("Rg_MG").Range("K12:K20") = Application.Transpose(.Range(.Cells(i, 2), .Cells(i, 10))) End With wb.Activate Application.ScreenUpdating = True End Sub

Hallo,
anbei:
'---- orginal von chris, mit meiner kleinen Änderung ----------------


Private Sub Rg_Vorlage_kopieren()
Dim wb     As Workbook
Dim thiswb As Workbook
Dim b      As Boolean
Dim i&, ze
Set thiswb = ThisWorkbook
i = ActiveCell.Row
For Each wb In Application.Workbooks
If wb.name Like "__Rechnungs-Programm Vers.*.xlsm" Then
b = True
Exit For
End If
Next wb
'   Stop
If Not b Then
' MsgBox "nix gefunden"
Exit Sub
End If
'------- ab hier meine Änderung --------------------------------
wb.Activate
ze = ActiveSheet.name
'- somit wird der Tabellenname von der Empfängerdatei übernommen
'---- und zurück ------------------------------------------------------
thiswb.Activat
With ActiveSheet
wb.Worksheets(ze).Range("K12:K20") = Application.Transpose(.Range(.Cells(i, 2), .Cells(i, 10)))
End With
wb.Activate
Application.ScreenUpdating = True
End Sub

funktioniert einwandfrei.
Meine Frage, wie kann ich dieses Makro für Doppelklick auf Zelle einbinden ?


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
Application.EnableEvents = True
If Not Intersect(Target, Range("B2:K65000")) Is Nothing Then
Cancel = True
ActiveSheet.Unprotect (getStrPasswort)
Range(Cells(Target.Row, 2), Cells(Target.Row, 10)).Select       'selektieren
ActiveSheet.Range("K12:K20") = Application.Transpose(Range(Cells(Target.Row, 2), Cells(Target.Row, 10)).Value)
End Sub

gruß kurt

Sub Unit() Dim Quelle As Variant, Ziel As Range Quelle = ActiveSheet.Cells(ActiveCell.Row, 2).Resize(1, 9).Value Set Ziel = ThisWorkbook.Worksheets(1).Range("K12:K20") Ziel.Value = Application.Transpose(Quelle) Set Ziel = Nothing End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean) Application.EnableEvents = True If Not Intersect(Target, Range("B2:K65000")) Is Nothing Then Cancel = True ActiveSheet.Unprotect (getStrPasswort) Range(Cells(Target.Row, 2), Cells(Target.Row, 10)).Select 'selektieren ActiveSheet.Range("K12:K20") = Application.Transpose(Range(Cells(Target.Row, 2), Cells(Target.Row, 10)).Value) 'Stop Dim Quelle As Variant, Ziel As Range Dim wb As Workbook Dim b As Boolean Set Quelle = ThisWorkbook Set Ziel = ThisWorkbook.Worksheets(2).Range("K12:K20") For Each wb In Application.Workbooks If wb.name Like "__Rechnungs-Programm Vers.*.xlsm" Then b = True Exit For End If Next wb Quelle = ActiveSheet.Cells(ActiveCell.Row, 2).Resize(1, 9).Value MsgBox Ziel Ziel.Value = Application.Transpose(Quelle) Set Ziel = Nothing End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean) Application.EnableEvents = True If Not Intersect(Target, Range("B2:K65000")) Is Nothing Then Cancel = True ActiveSheet.Unprotect (getStrPasswort) Range(Cells(Target.Row, 2), Cells(Target.Row, 10)).Select 'selektieren ActiveSheet.Range("K12:K20") = Application.Transpose(Range(Cells(Target.Row, 2), Cells(Target.Row, 10)).Value) Call In_Vorlage_kopieren End If End Sub

Private Sub In_Vorlage_kopieren() Dim wb As Workbook Dim thiswb As Workbook Dim b As Boolean Dim i&, ze Set thiswb = ThisWorkbook i = ActiveCell.Row For Each wb In Application.Workbooks If wb.name Like "__Rechnungs-Programm Vers.*.xlsm" Then b = True Exit For End If Next wb ' Stop If Not b Then ' MsgBox "nix gefunden" Exit Sub End If wb.Activate ze = ActiveSheet.name '- somit wird der Tabellenname von der Empfängerdatei übernommen '---- und zurück -- thiswb.Activate With ActiveSheet wb.Worksheets(ze).Range("K12:K20") = Application.Transpose(.Range(.Cells(i, 2), .Cells(i, 10))) End With wb.Activate Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

21
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zeile in andere Tabelle kopieren

21 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

21
Beiträge zum Forumthread

Beiträge zu diesem Forumthread