AW: Mappe speichern
12.09.2013 16:28:40
fcs
Hallo Gerhard,
hier Makros mit denen man so etwas umsetzen kann.
Es dürfen nur die beiden Dateien sichtbar geöffnet sein!! Andernfalls bricht das Makro den Kopiervorgang ab.
Besser wäre es, wenn der Name der Zieldatei bekannt wäre.
Gruß
Franz
'Makros in der Quelldatei im VBA-Editor unter dem Tabellenblatt einfügen, _
dessen Zeilen kopiert werden sollen
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'Nach Doppelklick in eine Zelle wird die Zeile mit der Zelle _
in die 2. geöffnete Datei kopiert.
If Target.Row >= 2 Then
Target.EntireRow.Select
If fncCopyZeile(rngZeile:=Target.EntireRow) = True Then
Cancel = True
Else
Target.Select
End If
End If
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'Nach markieren der kompletten Zeile und Rechte-Maus-Klick _
in eine Zelle der Zeile wird diese in die 2. geöffnete Datei kopiert.
If Target.Row >= 2 And Target.Columns.Count = Me.Columns.Count Then
If fncCopyZeile(rngZeile:=Target.EntireRow) = True Then
Cancel = True
End If
End If
End Sub
Private Function fncCopyZeile(rngZeile As Range) As Boolean
Dim wkbQuelle As Workbook
Dim wkbZiel As Workbook, wksZiel As Worksheet, strZielName As String
Dim iCount As Integer, strMsgTitel As String
Set wkbQuelle = ActiveWorkbook
strMsgTitel = "Zeile in 2. geöffnete Datei kopieren"
'2. geöffnetete, sichtbare Arbeitsmappe ermitteln
For Each wkbZiel In Application.Workbooks
If Windows(wkbZiel.Name).Visible = True Then
iCount = iCount + 1
If iCount > 2 Then
MsgBox "Es sind mehr als 2 Arbeitsmappen geöffnet", , strMsgTitel
Exit Function
End If
End If
Next
For Each wkbZiel In Application.Workbooks
If Windows(wkbZiel.Name).Visible = True Then
If wkbZiel.Name wkbQuelle.Name Then Exit For
End If
Next
If wkbZiel Is Nothing Then
MsgBox "Es ist keine 2. Arbeitsmappe geöffnet", , strMsgTitel
Exit Function
End If
If MsgBox("Aktive Zeile in Datei """ & wkbZiel.Name & """ kopieren?", _
vbQuestion + vbOKCancel, strMsgTitel) = vbOK Then
wkbZiel.Activate
Set wksZiel = ActiveSheet
rngZeile.Copy Destination:=wksZiel.Rows(2)
With wkbZiel
'neuen Namen der Zieldatei ermitteln
If wksZiel.Range("K2") = "" Then
MsgBox "In Zelle ""K2"" steht kein Dateiname. Makro wird abgebrochen", _
vbOKOnly, strMsgTitel
wksZiel.Rows(2).Delete
wkbQuelle.Activate
Exit Function
Else
strZielName = "C:\Daten\Messungen\" & wksZiel.Range("K2")
strZielName = "D:\Test\Zwischenordner\" & wksZiel.Range("K2")
End If
'Prüfen, ob Zieldatei schon existiert
If Dir(strZielName & ".xl*") "" Then
If MsgBox("Datei """ & strZielName & """ existiert bereits!" & vbLf & vbLf & _
"Datei überschreiben?", _
vbQuestion + vbYesNo + vbDefaultButton2, strMsgTitel) = vbNo Then
'kopierte Zeile wieder löschen
wksZiel.Rows(2).Delete
Else
'vorhandene Datei überschreiben
Application.DisplayAlerts = False
.SaveAs Filename:=strZielName
Application.DisplayAlerts = True
.Close savechanges:=False
fncCopyZeile = True
End If
Else
'Datei speichern und schliessen
.SaveAs Filename:=strZielName
.Close savechanges:=False
fncCopyZeile = True
End If
wkbQuelle.Activate
End With
End If
End Function