Transfer selected rows to sheet
"chris100" wrote in
message ...
[...]
At the moment when there are several dates of the same value in the
column, it will only append the last row of those dates. I need to
append any rows which have the same date as cell A1. Could you please
advise? I looked around but i'm afraid i don't know much about looping
(and evidently everything else in VBA for that matter...)
Regards,
Chris
Ok Chris, only slight modifications: added another
counter (j) to the last For... Next.
Please rerrange as per your need as I worked on my
copy without following your modifications.
--------------------------------------------
Sub CopyRow()
Dim SourceRange As Range, TargetRange As Range
Dim SearchRange As Range, LastWrittenCell As Range
Dim i, n As Integer, k As Integer, j As Integer, ItemToSearchFor
'--------------------------------------
' User definitions
n = 5 ' number of columns to append
Set SourceRange = [AA10]
Set TargetRange = [AG10]
'--------------------------------------
Set SearchRange = Range(SourceRange, SourceRange.End(xlDown))
If IsEmpty(TargetRange) Then
Set LastWrittenCell = TargetRange
k = 0
Else
k = 1
If IsEmpty(TargetRange.Offset(1, 0)) Then
Set LastWrittenCell = TargetRange
Else
Set LastWrittenCell = TargetRange.End(xlDown)
End If
End If
ItemToSearchFor = InputBox("Item To Search For:" & vbCrLf & "(case
sensitive)")
If ItemToSearchFor = "" Then
Exit Sub
End If
For Each i In SearchRange
If i.Value = ItemToSearchFor Then
Range(i, i.Offset(0, n - 1)).Copy LastWrittenCell.Offset(k + j, 0)
j = j + 1
End If
Next
End Sub
-----------------------------------
Ciao
Bruno
|