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).


File1/Sheet1:
contains a heading in row 1 and several data in records row 2 till last, whereby in column A for some records the data in it is the same and those who are the same are always sorted by each other.

Example:
1. Heading
2. AAA
3. AAA
4. AAA
5. BBB
6. BBB
7. CCC
8. DDD
9. DDD

When run the macro the required action is;
Step1:
1a) For the active cell (standing at that moment) look at the data in the active record in column A and select then all the complete rows were in column A the data is the same.
1b) Copy all the selected records.
1c) Keep in memory the active file/sheet name.

(This means when I run the macro and the active cell is D3, the macro select then the complete rows 2+3+4 because they have the same data in column A. Then it selects all this rows and keep in mind the name File1/Sheet1).

File1/Sheet2:
This contains in datafield A2 the reference to a file.
For example c:/Apps/import.xls

Step2:
2a) The macro should open the file as mentioned in File1/Sheet2 field A2 (then you opens File2/Sheet1).
2b) Then in this opened file delete all the records in it from row2 till last.
2c) Then copy the selected records from step1b of File1/Sheet1 into row2 etc of this File2/Sheet1.
2d) Save/Close the file File2.

Step3:
In the selected records of File1/Sheet1 set in all those records in column B the actual date of this copy action.

If somebody can help me out, thanks.

regards,
Johan

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