Zellen per VBA kopieren

Question

Hallo Excel-Spezialisten.

Ich habe folgendes Problem.
Ich möchte aus mehreren geöffneten Excel-Dateien, aus allen darin befindlichen Tabellenblättern die Zellen H6-I15 in eine ebenfalls geöffnete Datei in die Spalten H:I kopieren.

Vielen Dank im voraus für eure Hilfe

Hanni

Answer 1

Hallo,

schon mal mit Makro aufzeichnen versucht?

Gruß

Helmut

Answer 2

Hallo Hanni,

nachfolgendes Makro kopiert Dir aus allen geöffneten Exceldateien aus allen Tabellenblättern den Bereich "H6:I15" und fügt den kopierten Bereich in der aktuellen Datei in Blatt "Tabelle1" in die erste freie Zeile in Spalte H ein.
Für dieses Makro müssen alle auszulesenden Dateien in der gleichen Excelinstanz geöffnet sein.

Kopiere das Makro in ein StandardModul und starte es z.B. über eine Befehlsschaltfläche
Teste das Makro aber bitte in einer Testdatei und nicht gleich in Deiner Originaldatei.

Option Explicit

Sub Daten_kopieren()
Dim intAnzahlWorkbooks As Integer
Dim intAnzahlSheets As Integer
Dim lngFirstRow As Long

On Error GoTo ERRORHANDLER

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.Cursor = xlWait
.ErrorCheckingOptions.BackgroundChecking = False
End With

'Alle geöffneten Exceldateien
For intAnzahlWorkbooks = 1 To Workbooks.Count
'Alle Tabellenblätter in der geöffneten Exceldatei
For intAnzahlSheets = 1 To Workbooks(intAnzahlWorkbooks).Sheets.Count
'Wenn der Name der Exceldatei ein anderer ist als der, aus der das _
Makro gestartet wurde dann...
If Workbooks(intAnzahlWorkbooks).Name <> ActiveWorkbook.Name Then
'erste freie Zeile in Spalte H in der aktuellen Datei ermitteln und in _
Variable "lngFirstRow" schreiben
lngFirstRow = ActiveSheet.Cells(Rows.Count, 8).End(xlUp).Offset(1, 0).Row
'Daten kopieren
Workbooks(intAnzahlWorkbooks).Sheets(intAnzahlSheets).Range("H6:I15").Copy _
ActiveWorkbook.Sheets("Tabelle1").Cells(lngFirstRow, 8)
End If
Next intAnzahlSheets
Next intAnzahlWorkbooks
ERRORHANDLER:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.Calculate
.Cursor = xlDefault
.ErrorCheckingOptions.BackgroundChecking = True
End With
End Sub
Solltest Du nicht wissen, wie Du den Code in Deine Datei bekommst, dann schau mal auf meiner HP in der Rubrik Anleitungen und dort dann in der Anleitungsnummer 3 nach. Dort stelle ich dazu eine bebilderte Anleitung zur Verfügung, die Dir sicherlich helfen wird.

Bei Fragen melde Dich.

MfG,
Oliver
[sub]Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du[/sub]
[sup] ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.[/sup]

Answer 3

Danke Coros,

soweit funktioniert das Makro. Jedoch werden die in den Zellen befindlichen Formeln kopiert. Ich benötige jedoch die Werte.

Danke im voraus.

Answer 4

Hallo Hanni,

dann eben wie folgt.

Kopiere das Makro in ein StandardModul und starte es z.B. über eine Befehlsschaltfläche
Teste das Makro aber bitte in einer Testdatei und nicht gleich in Deiner Originaldatei.

Option Explicit

Sub Daten_kopieren()
Dim intAnzahlWorkbooks As Integer
Dim intAnzahlSheets As Integer
Dim lngFirstRow As Long

On Error GoTo ERRORHANDLER

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.Cursor = xlWait
.ErrorCheckingOptions.BackgroundChecking = False
End With

'Alle geöffneten Exceldateien
For intAnzahlWorkbooks = 1 To Workbooks.Count
'Alle Tabellenblätter in der geöffneten Exceldatei
For intAnzahlSheets = 1 To Workbooks(intAnzahlWorkbooks).Sheets.Count
'Wenn der Name der Exceldatei ein anderer ist als der, aus der das _
Makro gestartet wurde dann...
If Workbooks(intAnzahlWorkbooks).Name <> ActiveWorkbook.Name Then
'erste freie Zeile in Spalte H in der aktuellen Datei ermitteln und in _
Variable "lngFirstRow" schreiben
lngFirstRow = ActiveSheet.Cells(Rows.Count, 8).End(xlUp).Offset(1, 0).Row
'Daten kopieren
Workbooks(intAnzahlWorkbooks).Sheets(intAnzahlSheets).Range("H6:I15").Copy
ActiveWorkbook.Sheets("Tabelle1").Cells(lngFirstRow, 8).PasteSpecial
End If
Next intAnzahlSheets
Next intAnzahlWorkbooks
ERRORHANDLER:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.Calculate
.Cursor = xlDefault
.ErrorCheckingOptions.BackgroundChecking = True
End With
End Sub

MfG,
Oliver
[sub]Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du[/sub]
[sup] ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.[/sup]

Answer 5

Hallo Coros,

danke. Es funktioniert perfekt.