Copy and Paste Macro Help Please

[swolford]

I have data set on Sheet1 and I want to create worksheets based on unique values in Column A, I then want to copy the data and header for this value to the new worksheet.

 

[Redwolfx]

Try this

Sub OrganizeUnique()
Dim mycell As Range
Dim LastRow As Long
Dim Lastrow2 As Long
Dim WS As Worksheet
Dim Cat As String
Dim WSCount As Long
WSCount = Worksheets.Count
Application.ScreenUpdating = False
LastRow = Sheets(1).Range("A100000").End(xlUp).Row
    For Each mycell In Range("A2:A" & LastRow)
        Checksheet mycell.Value
    Next mycell
    For Each WS In ThisWorkbook.Worksheets
        If WS.Index > WSCount Then
            Cat = WS.Name
            
           For Each mycell In Sheets(1).Range("A2:A" & LastRow)
                If mycell.Value <> Cat Then
                    mycell.EntireRow.Hidden = True
                End If
            Next mycell
           
            Sheets(1).Range("A1:Z" & LastRow).SpecialCells(xlCellTypeVisible).Copy
            WS.Cells.PasteSpecial xlPasteValuesAndNumberFormats
        End If
        Sheets(1).Rows("1:" & LastRow).Hidden = False
    Next WS
    
Application.ScreenUpdating = True
End Sub

Sub Checksheet(mycell As String)
Dim WSto As Worksheet
On Error Resume Next
    'Sets WSto for ongoing use
    Set WSto = Sheets(mycell)
    If Err <> 0 Then
        Err.Clear
        Set WSto = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        WSto.Name = mycell
        If Err <> 0 Then
            GoTo Errhandler
        End If
    End If
On Error GoTo 0
Errhandler:
End Sub

 

[swolford]

Works Like a charm. How About one more piece of help.

I want the new sheets to have the format of sheet1. Can you add that?

 

[Redwolfx]

This one is untested, but try
See next post

 

[Redwolfx]

This one is untested, but try

Sub OrganizeUnique()
Dim mycell As Range
Dim LastRow As Long
Dim Lastrow2 As Long
Dim WS As Worksheet
Dim Cat As String
Dim WSCount As Long
WSCount = Worksheets.Count
Application.ScreenUpdating = False
LastRow = Sheets(1).Range("A100000").End(xlUp).Row
    For Each mycell In Range("A2:A" & LastRow)
        Checksheet mycell.Value
    Next mycell
    For Each WS In ThisWorkbook.Worksheets
        If WS.Index > WSCount Then
            Cat = WS.Name
            
           For Each mycell In Sheets(1).Range("A2:A" & LastRow)
                If mycell.Value <> Cat Then
                    mycell.EntireRow.Hidden = True
                End If
            Next mycell
           
            Sheets(1).Range("A1:Z" & LastRow).SpecialCells(xlCellTypeVisible).Copy
            WS.Cells.PasteSpecial         End If
        Sheets(1).Rows("1:" & LastRow).Hidden = False
    Next WS
    
Application.ScreenUpdating = True
End Sub

Sub Checksheet(mycell As String)
Dim WSto As Worksheet
On Error Resume Next
    'Sets WSto for ongoing use
    Set WSto = Sheets(mycell)
    If Err <> 0 Then
        Err.Clear
        Set WSto = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        WSto.Name = mycell
        If Err <> 0 Then
            GoTo Errhandler
        End If
    End If
On Error GoTo 0
Errhandler:
End Sub

</PRE>

 

[swolford]

The second one did not work.

 

[Redwolfx]

Sorry, I think there was a formatting error.

Sub OrganizeUnique()
Dim mycell As Range
Dim LastRow As Long
Dim Lastrow2 As Long
Dim WS As Worksheet
Dim Cat As String
Dim WSCount As Long
WSCount = Worksheets.Count
Application.ScreenUpdating = False
LastRow = Sheets(1).Range("A10000").End(xlUp).Row
    For Each mycell In Range("A2:A" & LastRow)
        Checksheet mycell.Value
    Next mycell
    For Each WS In ThisWorkbook.Worksheets
        If WS.Index > WSCount Then
            Cat = WS.Name
            
           For Each mycell In Sheets(1).Range("A2:A" & LastRow)
                If mycell.Value <> Cat Then
                    mycell.EntireRow.Hidden = True
                End If
            Next mycell
           
            Sheets(1).Range("A1:Z" & LastRow).SpecialCells(xlCellTypeVisible).Copy
            WS.Cells.PasteSpecial
        End If
        Sheets(1).Rows("1:" & LastRow).Hidden = False
    Next WS
    
Application.ScreenUpdating = True
End Sub
Sub Checksheet(mycell As String)
Dim WSto As Worksheet
On Error Resume Next
    'Sets WSto for ongoing use
    Set WSto = Sheets(mycell)
    If Err <> 0 Then
        Err.Clear
        Set WSto = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        WSto.Name = mycell
        If Err <> 0 Then
            GoTo Errhandler
        End If
    End If
On Error GoTo 0
Errhandler:
End Sub

 

[swolford]

It is getting there. It did not take the column widths as well. I really appreciate all of the help

 

[Redwolfx]

Try:

Sub OrganizeUnique()
Dim mycell As Range
Dim LastRow As Long
Dim Lastrow2 As Long
Dim WS As Worksheet
Dim Cat As String
Dim WSCount As Long
WSCount = Worksheets.Count
Application.ScreenUpdating = False
LastRow = Sheets(1).Range("A10000").End(xlUp).Row
    For Each mycell In Range("A2:A" & LastRow)
        Checksheet mycell.Value
    Next mycell
    For Each WS In ThisWorkbook.Worksheets
        If WS.Index > WSCount Then
            Cat = WS.Name
            
           For Each mycell In Sheets(1).Range("A2:A" & LastRow)
                If mycell.Value <> Cat Then
                    mycell.EntireRow.Hidden = True
                End If
            Next mycell
           
            Sheets(1).Range("A1:Z" & LastRow).SpecialCells(xlCellTypeVisible).Copy
            With WS.Range("A1") 
                 .Cells(1).PasteSpecial xlPasteColumnWidths
                 .Cells(1).PasteSpecial     
             End With

             Application.CutCopyMode = False

        End If
        Sheets(1).Rows("1:" & LastRow).Hidden = False
    Next WS
    
Application.ScreenUpdating = True
End Sub
Sub Checksheet(mycell As String)
Dim WSto As Worksheet
On Error Resume Next
    'Sets WSto for ongoing use
    Set WSto = Sheets(mycell)
    If Err <> 0 Then
        Err.Clear
        Set WSto = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        WSto.Name = mycell
        If Err <> 0 Then
            GoTo Errhandler
        End If
    End If
On Error GoTo 0
Errhandler:
End Sub

 

[swolford]

You have been very helpful. I have been able to apply this on multiple items. I am now running into an issue if the Column value exceeds the max value allowed for a sheet name it is not working. Is there a line of code to to only take the max# characters allowed for a sheet name in this code?