Tabelle in andere Mappe übertragen
12.02.2014 15:42:49
Christian
ich würde gerne eine Tabelle in eine andere Mappe einfügen. In der Tabelle befinden sich Zellbezüge zu 2 anderen Tabellen (insgesamt 18 Formeln mit ca 100 Bezügen), diese dann in 5000 Zeilen kopiert).
die beiden Tabellen, auf die sich die Zellbezüge beziehen, sind in beiden Mappen exakt dieselben.
Habt ihr eine Idee, wie ich die Daten übertragen kann, ohne soviele Zellbezüge anpassen zu müssen?
Außerdem gibt es noch folgendes Makro, dass sich auf diese Tabelle bezieht, kann ich das einfach in die andere Mappe übernehmen, oder muss ich da noch etwas anpassen?
Sub Makro1()
' Makro1 Makro
' Tastenkombination: Strg+y
Dim sh As Worksheet
Dim r As Range
Dim a As Variant
Dim Zellwert As Variant
Dim Minimum As Double
Dim Blattname As String
Set sh = ActiveSheet
Zellwert = sh.Cells(Rows.Count, 1).End(xlUp).Value
Set r = Columns("A:S")
sh.Sort.SortFields.Clear
sh.Sort.SortFields.Add Key:=r.Columns("C"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
sh.Sort.SortFields.Add Key:=r.Columns("F"), SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortNormal
sh.Sort.SortFields.Add Key:=r.Columns("D"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With sh.Sort
.SetRange r
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Set r = r.Columns("A")
r.Find(Zellwert).Select
Minimum = Application.Min(Range("S:S"))
a = Application.Match(Minimum, Range("S:S"), 0)
If IsNumeric(a) Then
Blattname = Format(Minimum, "yy") & " Jahre, " & Format(Minimum, "y") & " Tage - " & sh. _
Cells(a, 3)
If istBlattvorhanden(Blattname) = False Then ' prüfen ob es den Blattname schon gibt.
sh.Name = Blattname
Else
If Worksheets(Blattname) Is sh Then ' prüfen ob das Tabellenblatt mit dem Namen das _
aktuelle ist
sh.Name = Blattname
Else
MsgBox "Blattname schon vorhanden"
End If
End If
Else
MsgBox "nicht vorhanden"
End If
End Sub
Public Function istBlattvorhanden(Blattname As String) As Boolean
On Error GoTo fehler
If Not Worksheets(Blattname) Is Nothing Then istBlattvorhanden = True
fehler:
End Function