Sub
Ruecklaufquote()
Dim
wbQuelle1
As
Workbook
Dim
wbQuelle2
As
Workbook
Datei = Application.GetOpenFilename(
"Excel, *.xls*"
)
If
LCase(Datei)
Like
"fal*"
Then
Exit
Sub
Set
wbQuelle1 = Workbooks.Open(Datei,
ReadOnly
:=
True
)
wbQuelle1.Activate
Columns(
"A:BA"
).
Select
Selection.Copy
ThisWorkbook.Activate
Sheets(1).
Select
Columns(
"A:A"
).
Select
ActiveSheet.Paste
Application.CutCopyMode =
False
wbQuelle1.Close
ThisWorkbook.Activate
Sheets.Add After:=Sheets(Sheets.Count)
Datei = Application.GetOpenFilename(
"Excel, *.xls*"
)
If
LCase(Datei)
Like
"fal*"
Then
Exit
Sub
Set
wbQuelle2 = Workbooks.Open(Datei,
ReadOnly
:=
True
)
wbQuelle2.Activate
Columns(
"A:Z"
).
Select
Selection.Copy
ThisWorkbook.Activate
Sheets(2).
Select
Columns(
"A:A"
).
Select
ActiveSheet.Paste
Application.CutCopyMode =
False
wbQuelle2.Close
Sheets(1).
Select
Range(
"AZ1"
).
Select
ActiveCell.Formula =
"=COUNTA(U2:U10000)"
Range(
"AZ1"
).
Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=
False
, Transpose:=
False
Columns(
"A:AX"
).
Select
Application.CutCopyMode =
False
ActiveSheet.Range(
"$A$1:$AX$10000"
).RemoveDuplicates Columns:=Array(6, 7, 8, 20) _
, Header:=xlYes
Range(
"AZ2"
).
Select
ActiveCell.Formula =
"=COUNTA(U2:U10000)"
Range(
"AZ2"
).
Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=
False
, Transpose:=
False
Columns(
"A:AX"
).
Select
Application.CutCopyMode =
False
Sheets(2).
Select
Range(
"G1"
).
Select
ActiveCell.Formula =
"=COUNTA(D2:D10000)"
Range(
"G1"
).
Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=
False
, Transpose:=
False
Columns(
"A:D"
).
Select
Application.CutCopyMode =
False
ActiveSheet.Range(
"$A$1:$D$10000"
).RemoveDuplicates Columns:=Array(1, 2, 3, 4) _
, Header:=xlYes
Range(
"G2"
).
Select
ActiveCell.Formula =
"=COUNTA(D2:D10000)"
Range(
"G2"
).
Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=
False
, Transpose:=
False
Columns(
"A:D"
).
Select
Application.CutCopyMode =
False
End
Sub