Hi Johan,

Am Sat, 26 Nov 2016 14:42:45 +0100 schrieb Claus Busch:

try following macro. Modify the sheet names where necessary:

Sub CopyRows2()

if you want it case sensitive then try:

Sub CopyRows3()
Dim wshS As Worksheet, wshT As Worksheet
Dim wbkS As Workbook, wbkT As Workbook
Dim varFilter As Variant, varTmp() As String
Dim varData As Variant, varRows() As Variant
Dim myDic As Object
Dim i As Long, LrowS As Long, n As Long, j As Long, LCol As Long
Dim rngC As Range
Dim myPath As String

Set wbkS = ActiveWorkbook
Set wshS = wbkS.ActiveSheet
Application.ScreenUpdating = False

With wshS
LrowS = .Cells(.Rows.Count, "A").End(xlUp).Row
varData = .Range("A1:A" & LrowS)
For Each rngC In Intersect(Selection, .Columns("A"))
ReDim Preserve varTmp(n)
varTmp(n) = rngC
n = n + 1
Next

Set myDic = CreateObject("Scripting.Dictionary")
For i = LBound(varTmp) To UBound(varTmp)
myDic(varTmp(i)) = varTmp(i)
Next
varFilter = myDic.items
n = 0
For i = LBound(varFilter) To UBound(varFilter)
For j = 2 To UBound(varData)
If StrComp(varData(j, 1), varFilter(i), vbBinaryCompare) = 0 Then
ReDim Preserve varRows(n)
varRows(n) = j
n = n + 1
End If
Next
Next
myPath = wbkS.Sheets("Sheet1").Range("F2")
If Dir(myPath) < "" Then
Set wbkT = Workbooks.Open(myPath)
Set wshT = wbkT.Sheets("Sheet1")
wshT.UsedRange.ClearContents
Else
MsgBox "Workbook not available. Macro is canceled"
End If
n = 2
For i = LBound(varRows) To UBound(varRows)
.Rows(varRows(i)).Copy wshT.Cells(n, 1)
n = n + 1
Next
End With
wshT.Range("X2").Resize(UBound(varRows) + 1) = Format(Now, "dd.Mm.yyyy \/ hh:mm:ss")

wbkT.Close savechanges:=True
Application.ScreenUpdating = True
End Sub


Regards
Claus B.
--
Windows10
Office 2016