AW: Werte aus Tabelle 1 nach Tabelle 2 kopieren
02.04.2018 11:14:00
Peter(silie)
Hallo,
hier deine Mappe: https://www.herber.de/bbs/user/120799.xlsm
Da der Code ohne Copy und PasteSpecial funktioniert, sollte er auch
bei großen Datenmengen noch relativ schnell sein.
Hier nur der Code:
Option Explicit
'Enum containing the
'Columns we need in Sheet Kegler
'Change those numbers if neccessary
Private Enum Kxy
Holz = 27
Ueber = 32
Neuer = 41
Pudel = 45
End Enum
'Same like Kxy but for Hollern
Private Enum Hxy
Holz = 87
Ueber = 88
Neuer = 96
Pudel = 103
End Enum
Public Sub CopyData()
'SetValues need an Array of Values
'The Function GetValues will return this
'you can directly pass the GetValues
'Function to the SetValues Sub
'The Sub CopyData is unneccessary
'You can just add a Button
'with line of Code below.
SetValues GetValues
End Sub
Private Sub SetValues(ByRef kValues As Variant)
Dim shTarget As Worksheet 'data target sheet
Dim lRow As Long 'last row
Set shTarget = ThisWorkbook.Sheets("Kegler")
With shTarget
lRow = .Cells(.Rows.Count, Kxy.Holz).End(xlUp).Row + 1
.Range(.Cells(lRow, Kxy.Holz), .Cells(lRow, Kxy.Holz)).Resize( _
UBound(kValues) + 1).Value = kValues(1)
lRow = .Cells(.Rows.Count, Kxy.Ueber).End(xlUp).Row + 1
.Range(.Cells(lRow, Kxy.Ueber), .Cells(lRow, Kxy.Ueber)).Resize( _
UBound(kValues) + 1).Value = kValues(2)
lRow = .Cells(.Rows.Count, Kxy.Neuer).End(xlUp).Row + 1
.Range(.Cells(lRow, Kxy.Neuer), .Cells(lRow, Kxy.Neuer)).Resize( _
UBound(kValues) + 1).Value = kValues(3)
lRow = .Cells(.Rows.Count, Kxy.Pudel).End(xlUp).Row + 1
.Range(.Cells(lRow, Kxy.Pudel), .Cells(lRow, Kxy.Pudel)).Resize( _
UBound(kValues) + 1).Value = kValues(4)
End With
End Sub
Private Function GetValues() As Variant
Dim shSource As Worksheet 'data source sheet
Dim vData As Variant 'variant data of range
Dim lRow As Long 'last row
ReDim vData(1 To 4)
Set shSource = ThisWorkbook.Sheets("Hollern")
With shSource
'Data of the Column containing the Holz Data
lRow = .Cells(.Rows.Count, Hxy.Holz).End(xlUp).Row
vData(1) = .Range(.Cells(2, Hxy.Holz), _
.Cells(lRow, Hxy.Holz)).Value
'Data of the Column containing the Über Data
lRow = .Cells(.Rows.Count, Hxy.Ueber).End(xlUp).Row
vData(2) = .Range(.Cells(2, Hxy.Ueber), _
.Cells(lRow, Hxy.Ueber)).Value
'Data of the Column containing the Neuer Data
lRow = .Cells(.Rows.Count, Hxy.Neuer).End(xlUp).Row
vData(3) = .Range(.Cells(2, Hxy.Neuer), _
.Cells(lRow, Hxy.Neuer)).Value
'Data of the Column containing the Pudel Data
lRow = .Cells(.Rows.Count, Hxy.Pudel).End(xlUp).Row
vData(4) = .Range(.Cells(2, Hxy.Pudel), _
.Cells(lRow, Hxy.Pudel)).Value
End With
'Pass the Array to the Function
GetValues = vData
End Function