Sub
RUNTransfer()
Dim
rng
As
Range
Set
rng = Selection
TransferGesamttable rng
End
Sub
Sub
TransferGesamttable(rngData
As
Range)
Dim
wbkGes
As
Workbook
Dim
wshGes
As
Worksheet
Dim
iRow
As
Integer
, iCol
As
Integer
Dim
rngRow
As
Range, rngCol
As
Range
Dim
rng
As
Range
Set
wbkGes = Getworkbook(ThisWorkbook.Path &
"\Gesamttabelle.xlsx"
)
If
Not
wbkGes
Is
Nothing
Then
Set
wshGes = wbkGes.Worksheets(1)
Set
rng = wshGes.Rows(wshGes.UsedRange.Row + wshGes.UsedRange.Rows.Count)
iRow = 0
For
Each
rngRow
In
rngData.Rows
iCol = 1
For
Each
rngCol
In
rngRow.Cells
rng.Offset(RowOffset:=iRow).Cells(1, iCol).Value = rngCol.Value
iCol = iCol + 1
Next
iRow = iRow + 1
Next
Stop
End
If
End
Sub
Function
Getworkbook(
ByVal
fullName
As
String
)
As
Workbook
Dim
wbk
As
Workbook
Dim
bFound
As
Boolean
For
Each
wbk
In
Application.Workbooks
If
LCase(wbk.fullName) = LCase(fullName)
Then
Set
Getworkbook = wbk
bFound =
True
Exit
For
End
If
Next
If
Not
bFound
Then
Set
Getworkbook = Application.Workbooks.Open(fullName)
End
If
End
Function