Attempt Copy and Paste

**Puzzled in Philly** · 11-19-2009, 03:26 PM

I am attempting to create a workbook where new worksheets will be created and named based on the values in a set column range. Then copy and paste all the data in the rows containing that value to the newly created and named worksheet. Ex. Account # 12345 data pasted to the worksheet labeled 12345. Any assistance would be greatly appreciated.

**JBeaucaire** · 11-19-2009, 03:56 PM

This is a commonplace need. If you post up a sample workbook accurately depicting sample data, the sample "values in a set column range"... then I can adjust one of my macros for your layout.

Click GO ADVANCED and use the paperclip icon to post up your workbook.

**Puzzled in Philly** · 11-19-2009, 04:19 PM

Attached is a mock up. So Account 12345 and all the corresponding data through column 23 would need to be copied into its own worksheet labeled 12345.

**JBeaucaire** · 11-19-2009, 05:32 PM

Where is this column of values you indicated? Do you need the macro to ascertain the values by itself from column E?

**JBeaucaire** · 11-19-2009, 05:42 PM

This will create the sheets and parse the accounts to the account in order. So the macro will organize the sheets, too.

If you run it a second time, it doesn't ADD to the existing sheets, it replaces them.

Option Explicit

Sub ParseAccounts()
'JBeaucaire  (11/11/2009)
'Based on column E, data is filtered to individual sheets
'Creates sheets and sorts alphabetically in workbook
Dim LR As Long, i As Long, MyArr
Dim MyCount As Long, ws As Worksheet
Application.ScreenUpdating = False

Set ws = Sheets("Sheet1")
ws.Activate

Columns("E:E").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BB1"), Unique:=True
Columns("BB:BB").Sort Key1:=Range("BB2"), Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
MyArr = Application.WorksheetFunction.Transpose(Range("BB2:BB" & Rows.Count).SpecialCells(xlCellTypeConstants))

Range("BB:BB").Clear
Range("A1:Z1").AutoFilter

For i = 1 To UBound(MyArr)
    Range("A1:Z1").AutoFilter Field:=5, Criteria1:=MyArr(i)
    LR = Range("A" & Rows.Count).End(xlUp).Row
    If LR > 1 Then
        If Not Evaluate("=ISREF('" & MyArr(i) & "'!A1)") Then
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(i)
        Else
            Sheets(MyArr(i)).Move After:=Sheets(Sheets.Count)
            Sheets(MyArr(i)).Cells.Clear
        End If
        ws.Activate
        Range("A1:Z" & LR).Copy Sheets("" & MyArr(i) & "").Range("A1")
        Range("A1:Z1").AutoFilter Field:=5
        MyCount = MyCount + Sheets("" & MyArr(i)).Range("A" & Rows.Count).End(xlUp).Row - 1
        Sheets("" & MyArr(i)).Columns.AutoFit
    End If
Next i

ActiveSheet.AutoFilterMode = False
LR = Range("A" & Rows.Count).End(xlUp).Row - 1
MsgBox "Rows with data: " & LR & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
Application.ScreenUpdating = True
End Sub

This macro belongs in a regular module, not a sheet module or ThisWorkbook module.

**Puzzled in Philly** · 11-20-2009, 12:35 PM

I apologize, I should have been more specific. The list of account numbers would come from one worksheet, and the data from another. Ex. There is a sample of accounts taken (12341, 12344, 12348 etc.) The sample would be housed on the sample worksheet. The worksheets to be created and named would come from the sample worksheet. Once the new worksheets have been created and named, data from the data worksheet would be copied and pasted to its own worksheet (Account 12341 worksheet would have only 12341 data etc).

Also, the sample column would be "D" instead of "E". Thanks again for your help.

**JBeaucaire** · 03-01-2010, 06:22 PM

Here is my original macro updated to make it more "editable". It is friendlier to use than the one posted above. So use this instead as a basis.

Sub ParseItems()
'JBeaucaire  (11/11/2009)
'Based on selected column, data is filtered to individual sheets
'Creates sheets and sorts alphabetically in workbook
Dim LR As Long, i As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String
Application.ScreenUpdating = False

'Column to evaluate from, column A = 1, B = 2, etc.
   vCol = 1
   
'Sheet with data in it
   Set ws = Sheets("Data")

'Range where titles are across top of data, as string
    vTitles = "A1:Z1"
    
'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

'Get a temporary list of unique values from column A
    ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

'Sort the temporary list
    ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Put list into an array for looping (values cannot be the result of formulas, must be constants)
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

'clear temporary worksheet list
    ws.Range("EE:EE").Clear

'Turn on the autofilter, one column only is all that is needed
    ws.Range(vTitles).AutoFilter

'Loop through list one value at a time
For i = 1 To UBound(MyArr)
    ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(i)
    
    If Not Evaluate("=ISREF('" & MyArr(i) & "'!A1)") Then    'create sheet if needed
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(i)
    Else                                                     'clear sheet if it exists
        Sheets(MyArr(i)).Move After:=Sheets(Sheets.Count)
        Sheets(MyArr(i)).Cells.Clear
    End If
    
    ws.Range("A1:A" & LR).EntireRow.Copy Sheets(MyArr(i)).Range("A1")
    ws.Range(vTitles).AutoFilter Field:=vCol
    MyCount = MyCount + Sheets(MyArr(i)).Range("A" & Rows.Count).End(xlUp).Row - 1
    Sheets(MyArr(i)).Columns.AutoFit
Next i

'Cleanup
ws.AutoFilterMode = False
MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
Application.ScreenUpdating = True
End Sub

===========
Sorry I missed your message above. Here is a tweaked version that allows you to use a second sheet. Put the names to use in the second sheet from A2 downward, and call that sheet "Names".

Option Explicit

Sub ParseItems()
'JBeaucaire  (11/11/2009)
'Based on selected column, data is filtered to individual sheets
'Creates sheets and sorts alphabetically in workbook
Dim LR As Long, i As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, wsNames As Worksheet, MyArr As Variant, vTitles As String
Application.ScreenUpdating = False

'Column to evaluate from, column A = 1, B = 2, C = 3 etc.
   vCol = 1
   
'Sheet with data in it and sheet with list of names in column A
   Set ws = Sheets("Data")
   Set wsNames = Sheets("Names")
   
'Range where titles are across top of data, as string
    vTitles = "A1:Z1"
    
'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

'Get the list of values from another sheet
    MyArr = Application.WorksheetFunction.Transpose(wsNames.Range("A2:A" & Rows.Count).SpecialCells(xlCellTypeConstants))

'Turn on the autofilter, one column only is all that is needed
    ws.Range(vTitles).AutoFilter

'Loop through list one value at a time
For i = 1 To UBound(MyArr)
    ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(i)
    If Cells(Rows.Count, vCol).End(xlUp).Row > Range(vTitles).Row Then
        If Not Evaluate("=ISREF('" & MyArr(i) & "'!A1)") Then    'create sheet if needed
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(i)
        Else                                                     'clear sheet if it exists
            Sheets(MyArr(i)).Move After:=Sheets(Sheets.Count)
            Sheets(MyArr(i)).Cells.Clear
        End If
    
        ws.Range("A1:A" & LR).EntireRow.Copy Sheets(MyArr(i)).Range("A1")
        MyCount = MyCount + Sheets(MyArr(i)).Range("A" & Rows.Count).End(xlUp).Row - 1
    End If
    ws.Range(vTitles).AutoFilter Field:=vCol
    Sheets(MyArr(i)).Columns.AutoFit
Next i

'Cleanup
ws.AutoFilterMode = False
MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
Application.ScreenUpdating = True
End Sub

Does this work for you?