Thanks !!
Almost as wished.

1.Heading
2.AAA
3.AAA
4.AAA
5.BBB
6.BBB
7.CCC
8.CCC

It works oke if you select only for example B3+B5+B7 (one record for each different data in column A). If you select more then one field and in those selected records the data in column A is registered in more then one situation, then you get the code error on; srcsht.Range(Mid$(working, 2)).EntireRow.Copy

So you can't select B3:B4 (because AAA is double in it).
You can't select B3:B7 (because AAA is double, even for BBB).

But so far so good. It's amazing how it works till now.
Perhaps a minor change to solve this issue.

thanks,
Regards.

jmslab wrote:

Thanks !!
Almost as wished.

1.Heading
2.AAA
3.AAA
4.AAA
5.BBB
6.BBB
7.CCC
8.CCC

It works oke if you select only for example B3+B5+B7 (one record for
each different data in column A). If you select more then one field and
in those selected records the data in column A is registered in more
then one situation, then you get the code error on;
srcsht.Range(Mid$(working, 2)).EntireRow.Copy

So you can't select B3:B4 (because AAA is double in it).
You can't select B3:B7 (because AAA is double, even for BBB).

But so far so good. It's amazing how it works till now.
Perhaps a minor change to solve this issue.

I guess it doesn't like adding a row that's already been copied. Oh well.
Replace everything with this:

Sub foo()
Dim srcbk As Workbook, srcsht As Worksheet, cel As Range
Dim tgtbk As Workbook, flag As Boolean, L0, L1, wrk As String
ReDim working(0) As String
Set srcbk = ActiveWorkbook
Set srcsht = ActiveSheet
'Find the data.
working(0) = "A" & ActiveCell.Row
For Each cel In Selection.Cells
For L0 = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row
'Case-sensitive.
If Cells(L0, 1).Value = Cells(cel.Row, 1).Value Then
flag = False
For L1 = 0 To UBound(working)
If working(L1) = "A" & L0 Then flag = True
Next
If Not flag Then
ReDim Preserve working(UBound(working) + 1)
working(UBound(working)) = "A" & L0
End If
End If
Next
Next
'This assumes that the workbook is entered as a string value
'(e.g. literally "C:\Apps\import.xls"), not an Excel reference.
On Error Resume Next
Set tgtbk = Workbooks.Open(Sheets("Sheet2").Range("A2").Value)
On Error GoTo 0
If Not (tgtbk Is Nothing) Then
tgtbk.Activate
'Out with the old and in with the new.
Range("A2:A" & _
Cells.SpecialCells(xlCellTypeLastCell).Row).Entire Row.Delete
wrk = Join$(working, ",")
srcsht.Range(wrk).EntireRow.Copy
Range("A2").Select
ActiveSheet.Paste
tgtbk.Save
tgtbk.Close
For Each cel In Range(Replace$(wrk, "A", "B")).Cells
cel.Value = Date
Next
End If

Set cel = Nothing
Set srcsht = Nothing
Set tgtbk = Nothing
Set srcbk = Nothing
End Sub

--
And here I was hoping for a tactical plan that didn't involve martyrdom.

Auric_

SuperSuperthanks. Works perfect !!!

regards,
Johan