Copy a by macro special selected nr of rows into another file
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!
|