copy rows

  • Thread starter Thread starter Novice Lee
  • Start date Start date
N

Novice Lee

Hello

I have a spreadsheet that tracks the progress of projects. is there a way to
copy only the rows that contains my name (Column G), to a new sheetthat I
would have open?
 
The following macro will work efficiently so long as their are not more
than, say, 300 to 400 rows with your name in Column G (if you could have
more, I should be able to modify the code to handle it); change the values
in the five Const statements to reflect your actual setup...

Sub CopyMe()
Dim R As Range, M As Range
Const MyName As String = "Rick"
Const NameColumn As String = "G"
Const SourceSheet As String = "Sheet2"
Const DestinationCell As String = "A1"
Const DestinationSheet As String = "Sheet4"
With Worksheets(SourceSheet)
For Each R In Intersect(.UsedRange, .Columns(NameColumn))
If R.Value = MyName Then
If M Is Nothing Then
Set M = R.EntireRow
Else
Set M = Union(M, R.EntireRow)
End If
End If
Next
End With
M.Copy Worksheets(DestinationSheet).Range(DestinationCell)
End Sub
 
Sub COUNTme()
Dim row1 As Integer
row1 = 1
For count1 = 1 To 100
Cells(row1, 6).Select
If Selection = "MYNAME" Then
Call transfer
row1 = row1 + 1
Next
End Sub
Sub transfer()
Selection.EntireRow.Copy
Workbooks.otherworkbook.active
Sheets("MYNAME").Select
Range("A1").Select
Insert.Row
Paste
originalworkbook.Select
End Sub
 
Try code like the following. Change the lines marked with <<< to the
appropriate values. SourceWS is the worksheet with the data you want
to copy. DestWS is the worksheet to which the records will be copied.
DestCell is the first cell where the records are to be copied.
StartRow is the row on SoureWS where the data starts. YourName is your
name, to be tested in column G.

Sub AAA()
Dim SourceWS As Worksheet
Dim DestWS As Worksheet
Dim DestCell As Range
Dim StartRow As Long
Dim EndRow As Long
Dim RowNdx As Long
Dim YourName As String

Set SourceWS = Worksheets("Sheet1") '<<< CHANGE
Set DestWS = Worksheets("Sheet2") '<<< CHANGE
Set DestCell = DestWS.Range("A1") '<<< CHANGE
StartRow = 1 '<<< CHANGE
YourName = "John Smith"

With SourceWS
EndRow = .Cells(.Rows.Count, "G").End(xlUp).Row
For RowNdx = StartRow To EndRow
If StrComp(.Cells(RowNdx, "G").Value, _
YourName, vbTextCompare) = 0 Then
.Cells(RowNdx, "A").EntireRow.Copy DestCell
Set DestCell = DestCell(2, 1)
End If
Next RowNdx
End With
End Sub

Cordially,
Chip Pearson
Microsoft Most Valuable Professional
Excel Product Group, 1998 - 2009
Pearson Software Consulting, LLC
www.cpearson.com
(email on web site)
 
Since we are copying entire rows, perhaps it would be better to specify a
DestinationRow rather than a DestinationCell. Use this modified macro
instead of the one I posted earlier...

Sub CopyMe()
Dim R As Range, M As Range
Const MyName As String = "Rick"
Const NameColumn As String = "G"
Const SourceSheet As String = "Sheet2"
Const DestinationRow As Long = 1
Const DestinationSheet As String = "Sheet4"
With Worksheets(SourceSheet)
For Each R In Intersect(.UsedRange, .Columns(NameColumn))
If R.Value = MyName Then
If M Is Nothing Then
Set M = R.EntireRow
Else
Set M = Union(M, R.EntireRow)
End If
End If
Next
End With
M.Copy Worksheets(DestinationSheet).Rows(DestinationRow)
End Sub
 
Back
Top