AW: Excel Zellwerte in andere Excel Datei kopieren
15.01.2013 03:36:09
fcs
Hallo Alexander,
hier ein entsprechendes Makro.
Wichtig ist hier die Verwendung von entsprechenden Objekt-Variablen für die involvierten Arbeitsmappen und Tabelleblätter, um die Kopieraktionen einfach programmieren zu können.
Das Makro ist so aufgebaut, dass die Zieldatei bei Bedarf geöffnet wird. Hier muss du ggf. noch den Pfad anpassen
Gruß
Franz
Sub BemusterungsAuftragSpeichern()
Dim wbQuelle As Workbook, wksQuelle As Worksheet
Dim wbZiel As Workbook, wksZiel As Worksheet
Dim strZiel As String, strPfadZiel As String
Dim bolOpen As Boolean
Dim Zeile_Z As Long, Zelle_Letzte As Range
If MsgBox("Bemusterungsauftrag jetzt speichern?", vbQuestion + vbOKCancel, _
"Speichern Bemusterungsauftrag") = vbCancel Then GoTo Fehler
On Error GoTo Fehler
Set wbQuelle = ActiveWorkbook 'Datei "Laufkarte_zur_Auftragsabwicklung.xlsm"
Set wksQuelle = wbQuelle.Worksheets("Vertrieb")
Application.ScreenUpdating = False
strPfadZiel = "C:\Users\Public\Test" '### anpassen ##!!!
strPfadZiel = wbQuelle.Path 'wenn beide Dateien im gleichen Verzeichnis
strZiel = "Auflistung_der_Bemusterungsaufträge.xlsx"
If fncCheckWorkbookOpen(strZiel) Then
Set wbZiel = Application.Workbooks(strZiel)
bolOpen = True
Else
Set wbZiel = Application.Workbooks.Open(strPfadZiel & Application.PathSeparator _
& strZiel)
bolOpen = False
End If
Set wksZiel = wbZiel.Worksheets("Bemusterungsaufträge")
With wksZiel
'nächste Einfüge-Zeile ermitteln
Set Zelle_Letzte = .Cells.Find(What:="*", After:=Range("A1"), _
LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByRows, _
searchdirection:=xlPrevious)
If Zelle_Letzte Is Nothing Then
Zeile_Z = 1
Else
Zeile_Z = Zelle_Letzte.Row + 1
End If
'Zellinhalte übertragen - nur Werte
wksQuelle.Range("D4:D8").Copy
.Cells(Zeile_Z, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
wksQuelle.Range("L59:L65").Copy
.Cells(Zeile_Z, 6).PasteSpecial Paste:=xlPasteValues
wksQuelle.Range("D9:D13").Copy
.Cells(Zeile_Z, 7).PasteSpecial Paste:=xlPasteValues, Transpose:=True
wksQuelle.Range("M3:M5").Copy
.Cells(Zeile_Z, 12).PasteSpecial Paste:=xlPasteValues, Transpose:=True
wksQuelle.Range("M7").Copy
.Cells(Zeile_Z, 13).PasteSpecial Paste:=xlPasteValues
wksQuelle.Range("M11:M13").Copy
.Cells(Zeile_Z, 14).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With
Application.CutCopyMode = False
If bolOpen = False Then
wbZiel.Close savechanges:=True
End If
Fehler:
Application.ScreenUpdating = True
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Set wbZiel = Nothing: Set wksZiel = Nothing: Set Zelle_Letzte = Nothing
Set wbQuelle = Nothing: Set wksQuelle = Nothing
End Sub
Public Function fncCheckWorkbookOpen(ByVal strName As String) As Boolean
'Prüft ob Arbeitsmappe geöffnet ist
Dim wb As Workbook
On Error GoTo Fehler
fncCheckWorkbookOpen = True
Set wb = Application.Workbooks(strName)
Fehler:
With Err
Select Case .Number
Case 0 'Alles ok
Case Else
fncCheckWorkbookOpen = False
End Select
End With
End Function