Option Explicit
Sub Ken01()
'Copy all rows with column 1 matching value
' of selected cell to next available row
' in sheet named with value of matching cell 2000-06-09
' 2007-04-25 create sheet if needed, return to original sheet
Dim I As Long
Dim original As Worksheet
Application.ScreenUpdating = False
'On Error Resume Next
Dim mrow As Long
mrow = Cells.SpecialCells(xlLastCell).Row
Dim ThisText As String
Dim Str1 As String
Dim Row As Long
ThisText = ActiveCell.Value
'ThisText = InputBox("Supply Name to copy", , ThisText)
'MsgBox "You chose" & ThisText
If ActiveSheet.Name = ThisText Then
MsgBox "You can't start from a sheet named " & ThisText
Exit Sub
End If
Set original = ActiveSheet
For I = 1 To mrow
If Cells(I, 1) = ThisText Then
Str1 = Str1 & "," & I & ":" & I
End If
Next I
Str1 = Mid(Str1, 2, 2000)
Range(Str1).Copy
'Sheets("Bob").Activate
On Error Resume Next
Application.DisplayAlerts = False
Sheets(ThisText).Activate
If Err.Number <> 0 Then
If Err.Number <> 9 Then MsgBox Err.Number & " -- error "
'-- see http://www.mvps.org/dmcritchie/excel/sheets.htm
Sheets.Add After:=Sheets(Sheets.Count) '-- place at end
'Rename current Sheet
ActiveSheet.Name = ThisText
End If
Application.DisplayAlerts = True
On Error GoTo 0
If [A1].Value <> "" Then
Cells(1, 1).End(xlDown).Select
Row = ActiveCell.Row
Range(Cells(Row + 1, 1), Cells(Row + 1, 1)).Select
End If
ActiveSheet.Paste
original.Activate 'Return to original worksheet
Application.ScreenUpdating = False
End Sub
|
Cell A13 containing "Bob" is selected (boldface for display only).
|
Sheetname: Bob
|
Insert another row above your first row.
A1: Name
B1: Amount
Select row 1
Data --> Filter --> Autofilter
Click on arrow in Name column header (cell A1) ChooseBob Copy the area showing data (ctrl+c) Insert new worksheet (Edit --> Insert worksheet) Paste (ctrl+v) intot the new worksheet
Another possibility, simply select all of data and sort on Column A.
Please send your comments concerning this web page to: David McRitchie send email comments
Copyright © 1997 - 2004, F. David McRitchie, All Rights Reserved