Bestimmte Zellen in andere Tabelle kopieren

Question

Hallo zusammen,

leider bin ich was VBA belangt nicht so bewandert. Jetzt brauche ich
aber dringend ein Makro, das mir verschiedene Zellen einer
Quelltabelle in eine Zieltabelle kopiert.
Die Quelltabellen haben alle unterschiedliche Namen, das
Arbeitsblatt heißt aber immer "Sheet1". In der Zieldatei heisst das
Arbeitsblatt "Tabelle1"

1. Kopieren der Zellen E3, P3, P4, K52 aus der Quelldatei

2. Einfügen in A1, B1, C1, D1 in der Zieldatei

3. Wenn Zeile 1 schon belegt ist, dann einfügen in 2. Wenn 2 schon
belegt ist, dann 3, usw.

4. Beim Einfügen sollen die Werte eingefügt werden (ohne Formel).
Das Zahlenformat sollte aber beibehalten werden.

5. Ideal wäre es, wenn es einen Button gäbe, der einen auffordert
die Quelldatei auszuwählen.

Vielen Dank im Voraus

Answer 1

Hallo,

kopiere das folgende Makro in ein Standardmodul deiner Zielarbeitsmappe:

Sub Oeffnen_und_kopieren()
Dim Datei As Variant
Dim Quelle, Ziel As String
Dim bExists, MappeOffen As Boolean
Dim i As Integer
Dim lZeile As Long
Dim Rückgabe


'Datei-Öffnen Dialog aufrufen
Datei = Application.GetOpenFilename(FileFilter:="Microsoft Excel-Dateien (*.xl*), *.xl*", Title:="EINE Datei zum Öffnen auswählen")
If Datei = False Then
'Makro abbrechen wenn Benutzer den Öffnen-Dialog abbricht
MsgBox "Der Benutzer hat abgebrochen.", vbInformation
Exit Sub
End If


'Prüfen, ob Datei schon offen ist
For i = 1 To Workbooks.Count
If Workbooks(i).FullName = Datei Then
'ausgewählte Mappe ist bereits offen
MappeOffen = True
'Frage, ob Daten kopiert werden sollen
Rueckgabe = MsgBox("Die Arbeitsmappe " & Quelle & " ist bereits offen! Sollen die Daten kopiert werden?", vbYesNo + vbQuestion, "Mappe bereits offen")
'Abbruch des Makros
If Rueckgabe = vbNo Then Exit Sub
'Name der Quelldatei in Variable schreiben
Quelle = Workbooks(i).Name
End If
Next i

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'ausgewählte Datei öffnen, falls diese noch nicht offen ist
If MappeOffen = False Then
Workbooks.Open (Datei)
'Name der Quelldatei in Variable schreiben
Quelle = ActiveWorkbook.Name
End If

'Name der Zielarbeitsmappe wird in Datei geschrieben
Ziel = ThisWorkbook.Name

'Prüfen, ob Tabellenblatt mit Namen Sheet1 in Quelldatei existiert
For i = 1 To Workbooks(Quelle).Sheets.Count
If Workbooks(Quelle).Sheets(i).Name = "Sheet1" Then
bExists = True: Exit For
End If
Next i

'Abbruch des Makros falls kein Arbeitsblatt mit dem Namen Sheet1 existiert
If bExists = False Then
MsgBox "In der Arbeitsmappe " & Quelle & " existiert kein Arbeitsblatt mit dem Namen Sheet1! Abbruch!", 16, "Fehlermeldung"
Exit Sub
End If

'Festlegen der Zeile zum Einfügen der Daten in Tabelle1
lZeile = Workbooks(Ziel).Sheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1

'Prüfen, ob erste Zeile leer ist, falls ja, Zeilenzähler auf 1 setzen
If Workbooks(Ziel).Sheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Row = 1 Then
If IsEmpty(Workbooks(Ziel).Sheets("Tabelle1").UsedRange) Then lZeile = 1
End If

'Kopieren der Daten - E3 wird nach Spalte A kopiert
Workbooks(Quelle).Sheets("Sheet1").Range("E3").Copy
Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 1).PasteSpecial Paste:=xlPasteValues 'Werte kopieren
Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 1).PasteSpecial Paste:=xlPasteFormats 'Formate kopieren
'P3 wird nach Spalte B kopiert
Workbooks(Quelle).Sheets("Sheet1").Range("P3").Copy
Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 2).PasteSpecial Paste:=xlPasteValues
Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 2).PasteSpecial Paste:=xlPasteFormats
'P4 wird nach Spalte C kopiert
Workbooks(Quelle).Sheets("Sheet1").Range("P4").Copy
Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 3).PasteSpecial Paste:=xlPasteValues
Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 3).PasteSpecial Paste:=xlPasteFormats
'K52 wird nach Spalte D kopiert
Workbooks(Quelle).Sheets("Sheet1").Range("K52").Copy
Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 4).PasteSpecial Paste:=xlPasteValues
Workbooks(Ziel).Sheets("Tabelle1").Cells(lZeile, 4).PasteSpecial Paste:=xlPasteFormats

'Quelldatei schließen, wenn diese über das Makro geöffnet wurde
If MappeOffen = False Then Workbooks(Quelle).Close

'Meldung, dass Daten kopiert wurden
MsgBox "Die Daten aus der Datei " & Quelle & " wurden kopiert!", 64, "Information"

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Wenn du willst, kannst du eine Schaltfläche in deine Arbeitsmappe einfügen, mit der du das Makro starten kannst. Wie das geht, kannst du z.B. hier nachlesen.

Gruß

M.O.

Answer 2

Perfekt.
Klasse, vielen vielen Dank. Es läuft einwandfrei :)

Answer 3

Hallo,

gern geschehen :-). Und danke für die Rückmeldung.

Gruß

M.O.