jmslab wrote:

As part of a complex process of actions, there is a new part where I can
use some help. I think it's easy if you knows the correct code :) (as
Always).

[snip]

As is often the case, your description of what's needed translates
practically 1:1 to the actual code.

If, somehow, there are no matches to the source data (and there *should* be
at least one match: the source data itself), then nothing will happen.

If the target workbook doesn't exist, this will silently ignore the error
and effectively do nothing.

Sub foo()
Dim srcbk As Workbook, srcsht As Worksheet, cel As Range
Dim tgtbk As Workbook
Dim working As String, L0 As Variant
Set srcbk = ActiveWorkbook
Set srcsht = ActiveSheet
'Find the data.
For L0 = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row
'Case-sensitive.
If Cells(L0, 1).Value = Cells(ActiveCell.Row, 1).Value Then
working = working & ",A" & Trim$(Str$(L0))
End If
Next
If Len(working) Then
'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
srcsht.Range(Mid$(working, 2)).EntireRow.Copy
Range("A2").Select
ActiveSheet.Paste
tgtbk.Save
tgtbk.Close
For Each cel In Range(Mid$(Replace$(working, "A", "B"), 2)).Cells
cel.Value = Date
Next
End If
End If

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

--
The zombie invasion has begun! It's every man for himself!

Thanks a lot !!!
Perhaps a misstake in it. I'd tried to use but nothing happend.
No selection, no open book and no copy of data.
Whats going wrong ?

regards,
Johan

Oeps..... misstake by me. Sorry !!!!.
Copied the macro in the wrong part of my total process.
It works just as I asked. Great !! Thanks. !!!!!!

Perhaps you can help me out with a (minor?)change.

The macro works now on one selected field and it looks now in column A if there is the same data in it in the nearby records. When the data in column A is the same in several records the macro select all this records for copying.

Is it possible to combine this macro with an option that if you selected more then one datafield (for example B4:B10) that the macro looks also to column A but now there is the possiblity that there is not only AAA filled in, but also in some records BBB. Then the macro has to select also all the AAA records but also together the BBB records (so.... there could be more then one unique value in column A).

De rest of the macro keeps the same - copy to another file.

regards,
Johan

jmslab wrote:

Perhaps you can help me out with a (minor?)change.

The macro works now on one selected field and it looks now in column A
if there is the same data in it in the nearby records. When the data in
column A is the same in several records the macro select all this
records for copying.

Is it possible to combine this macro with an option that if you selected
more then one datafield (for example B4:B10) that the macro looks also
to column A but now there is the possiblity that there is not only AAA
filled in, but also in some records BBB. Then the macro has to select
also all the AAA records but also together the BBB records (so.... there
could be more then one unique value in column A).

De rest of the macro keeps the same - copy to another file.

So, you want every row with a selected cell to be part of what's used as the
basis for copying? Using your original example, if rows 6 and 8 are
selected, you want to match both BBB and DDD? If so, it's just a matter of
replacing the "Find the data" section with this:

'Find the data.
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
working = working & ",A" & Trim$(Str$(L0))
End If
Next
Next

(The next line should be "If Len(working) Then".)

No options needed. Whether you select a single cell or the entire sheet,
this should do what you want.

--
War is the greatest of teachers, and not all of its lessons are bad.
Their cost is just so terribly high.

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