AW: Bereich in ein anderes Tabellenblatt kopieren
25.10.2015 21:35:47
fcs
Hallo Gerald,
hier ein entsprechendes Makro.
Das Blatt in dem die Daten eingefügt werden sollen ("Data_HW") muss das aktive Blatt sein, wenn das Makro gestartet wird.
Man könnte es aber auch anders herum aufziehen und mit dem Blatt starten, in dem die zu kopierenden Daten stehen.
Gruß
Franz
Sub Copy_Daten_nach_Data_HW()
Dim wksZiel As Worksheet
Dim wkbQuelle As Workbook
Dim arrWkb() As Workbook, intWkb As Integer, intAuswahl As Integer
Dim Zeile_Z As Long, rngCopy As Range
Dim MsgPrompt As String, MsgTitle As String
Set wksZiel = ActiveSheet
MsgTitle = "Makro: Copy_Daten_nach_Data_HW"
If wksZiel.Name "Data_HW" Then
MsgBox "Das Blatt ""Data_HW"" muss beim Start des Makros das aktive Blatt sein!", _
vbInformation + vbOKOnly, MsgTitle
Else
'geöffnete Arbeitsmappen suchen für Auswahl
For Each wkbQuelle In Application.Workbooks
If Application.Windows(wkbQuelle.Name).Visible = False Then
ElseIf wkbQuelle.Name = wksZiel.Parent.Name Then
Else
intWkb = intWkb + 1
ReDim Preserve arrWkb(1 To intWkb)
MsgPrompt = vbLf & MsgPrompt & intWkb & " - " & wkbQuelle.Name
Set arrWkb(intWkb) = wkbQuelle
End If
Next
'Inputbox für Auswahl anzeigen
intAuswahl = Application.InputBox( _
"Aus welcher Mappe sollen die Daten eingelesen werden?" & MsgPrompt, _
MsgTitle, 1, Type:=1)
Select Case intAuswahl
Case 0 'Abbruch
Case 1 To intWkb
'zu kopierenden Bereich setzen
Set wkbQuelle = arrWkb(intWkb)
With wkbQuelle.Worksheets(1)
Set rngCopy = .Range(.Cells(2, 1), .Cells(.Rows.Count, 7).End(xlUp))
End With
If rngCopy.Row > 1 Then
With wksZiel
'gelbe Zeile
Zeile_Z = .Cells(.Rows.Count, 1).End(xlUp).Row
'Leerzeilen einfügen
.Rows(Zeile_Z).Resize(rngCopy.Rows.Count).Insert
'Markieren bereich kopieren/einfügen
rngCopy.Copy Destination:=.Cells(Zeile_Z, 2)
'in Spalte A die fortlaufende Nummer fortführen
With .Cells(Zeile_Z, 1).Resize(rngCopy.Rows.Count, 1)
.FormulaR1C1 = "=IF(ISTEXT(R[-1]C1),1,R[-1]C1+1)"
.Value = .Value
End With
End With
Else
MsgBox "Keine Daten zum kopieren gefunden", vbOKOnly, MsgTitle
End If
Set rngCopy = Nothing
Set wkbQuelle = Nothing
Case Else
MsgBox "Ungültige Auswahl", vbOKOnly, MsgTitle
End Select
End If
End Sub