Copy To New Worksheets

[billandrew]

Hello All

Attempting to expand my VBA knowledge. I am trying to copy a specific value (This case Maine & Virginia) from Sheet 1 to the newly added Maine & Virginia worksheets. I am using the below code which was provided in part by this Forum.

I would also like to copy the header row & in the future add additional state named sheets and the data from Sheet 1 to those sheets.
Sub copyif()
Dim lr As Long, ws As Worksheets, lr2 As Long
Dim wsa As Worksheet

Application.ScreenUpdating = False
Set wsa = ActiveSheet
ThisWorkbook.Worksheets.Add(after:=Sheets(Sheets.Count)).Name = "Maine"
ThisWorkbook.Worksheets.Add(after:=Sheets(Sheets.Count)).Name = "Virginia"
wsa.Activate

lr = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
lr2 = 1
For i = 2 To lr

If Cells(i, 3).Value = "Maine" Then
Worksheets("Maine").Rows(lr2).Value = Worksheets("Sheet1").Rows(i).Value

ElseIf Cells(i, 3).Value = "Virginia" Then
Worksheets("Virginia").Rows(lr2).Value = Worksheets("Sheet1").Rows(i).Value


lr2 = lr2 + 1
End If
Next i
Application.ScreenUpdating = True


End Sub

 

[billandrew]

About 7000 to 8000

 

[Fluff]

You could use something like this, but it will be considerably slower than my previous code.
ie about 22 seconds, rather than 0.5

Sub loopofabove()

    Dim Rw As Long
    Dim UsdRws As Long
    Dim OSht As Worksheet
    
Application.ScreenUpdating = False

    Set OSht = Sheets("[COLOR=#ff0000]Input[/COLOR]")
    UsdRws = OSht.Range("C" & Rows.Count).End(xlUp).Row
    
    If WorksheetFunction.CountIf(OSht.Columns(3), "[COLOR=#ff0000]ACD[/COLOR]") > 0 Then
        Sheets.Add.Name = "[COLOR=#ff0000]ACD[/COLOR]"
        OSht.Rows(1).Copy Sheets("[COLOR=#ff0000]ACD[/COLOR]").Range("A1")
    End If
    If WorksheetFunction.CountIf(OSht.Columns(3), "[COLOR=#ff0000]BCQ[/COLOR]") > 0 Then
        Sheets.Add.Name = "[COLOR=#ff0000]BCQ[/COLOR]"
        OSht.Rows(1).Copy Sheets("[COLOR=#ff0000]BCQ[/COLOR]").Range("A1")
    End If
    If WorksheetFunction.CountIf(OSht.Columns(3), "[COLOR=#ff0000]ZZZ[/COLOR]") > 0 Then
        Sheets.Add.Name = "ZZZ"
        OSht.Rows(1).Copy Sheets("[COLOR=#ff0000]ZZZ[/COLOR]").Range("A1")
    End If
    If WorksheetFunction.CountIf(OSht.Columns(3), "[COLOR=#ff0000]GHT[/COLOR]") > 0 Then
        Sheets.Add.Name = "[COLOR=#ff0000]GHT[/COLOR]"
        OSht.Rows(1).Copy Sheets("[COLOR=#ff0000]GHT[/COLOR]").Range("A1")
    End If
    If WorksheetFunction.CountIf(OSht.Columns(3), "[COLOR=#ff0000]XXX[/COLOR]") > 0 Then
        Sheets.Add.Name = "[COLOR=#ff0000]XXX[/COLOR]"
        OSht.Rows(1).Copy Sheets("[COLOR=#ff0000]XXX[/COLOR]").Range("A1")
    End If

    For Rw = 2 To UsdRws
        Select Case OSht.Range("C" & Rw).Value
            Case "[COLOR=#ff0000]ACD[/COLOR]", "[COLOR=#ff0000]BCQ[/COLOR]", "[COLOR=#ff0000]ZZZ[/COLOR]", "[COLOR=#ff0000]GHT[/COLOR]", "[COLOR=#ff0000]XXX[/COLOR]"
                OSht.Rows(Rw).Copy Sheets(OSht.Range("C" & Rw).Value).Range("A" & Rows.Count).End(xlUp).Offset(1)
        End Select
    Next Rw

End Sub

You'll need to change the bits in red to match your data

 

[Fluff]

Alternatively rather than having a message box as per my code in post#8 you could use this

Sub AddSht_FltrPaste()
' billandrew (book11)

    Dim Cl As Range
    Dim UsdRws As Long
    Dim OSht As Worksheet
    Dim arr As Variant
Application.ScreenUpdating = False

    Set OSht = Sheets("[COLOR=#ff0000]Input[/COLOR]")
    UsdRws = OSht.Range("C" & Rows.Count).End(xlUp).Row
    OSht.Range("A1:G1").AutoFilter
    arr = Array("[COLOR=#ff0000]ACD[/COLOR]", "[COLOR=#ff0000]BCQ[/COLOR]", "[COLOR=#ff0000]ZZZ[/COLOR]", "[COLOR=#ff0000]GHT[/COLOR]", "[COLOR=#ff0000]XXX[/COLOR]")

    With CreateObject("scripting.dictionary")
        For Each Cl In Range("C2:C" & UsdRws)
            If IsNumeric(Application.Match(Cl.Value, arr, False)) Then
                If Not .exists(Cl.Value) Then
                    .Add Cl.Value, Nothing
                    OSht.Range("A1:G" & UsdRws).AutoFilter field:=3, Criteria1:=Cl.Value
                    Sheets.Add(After:=Sheets(Sheets.Count)).Name = Cl.Value
                    OSht.Range("A1:G" & UsdRws).SpecialCells(xlCellTypeVisible).Copy _
                        Sheets(Cl.Value).Range("A1")
                End If
            End If
        Next Cl
    End With
    OSht.Range("A1:G1").AutoFilter

End Sub

Once again changing the bits in red, to suit

 

[billandrew]

Magnificent....

Can you elaborate on the worksheet.function and the countif function.

 

[Fluff]

CountIf is an excel function & doesn't exist in VBA, so in order to use it in VBA you need to do WorksheetFunction.CountIf.
The CountIf function itself counts how many times a value exists within a certain range so

If WorksheetFunction.CountIf(OSht.Columns(3), "[COLOR=#ff0000]ACD[/COLOR]") > 0 Then
        Sheets.Add.Name = "[COLOR=#ff0000]ACD[/COLOR]"
        OSht.Rows(1).Copy Sheets("[COLOR=#ff0000]ACD[/COLOR]").Range("A1")

Counts how many times ACD occurs in Col C of the sheet & if that count is greater than 0 (ie it exists) then a new sheet will be added, named & the header row copied over.
However, if that value does not exist, Countif will return 0 & no sheet will be added

 

[billandrew]

What if... I wanted to copy only the rows of a desired value in Column B and Column E.

 

[My Aswer Is This]

Here is a script I wrote but it uses loop which may be too slow for you I did not test speed. It looks in column "C" for the sheet name and then copies the row to the proper sheet.
If the sheet does not exist it skips over that row.

Sub Copy_Row_To_Sheet()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Sheets("Sheet1").Activate
Lastrow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
On Error GoTo M
    For i = 2 To Lastrow
    ans = Cells(i, 3).Value
        Rows(i).Copy Sheets(ans).Rows(Sheets(ans).Cells(Rows.Count, "A").End(xlUp).Row + 1)
M:
    Next
Application.ScreenUpdating = True
End Sub

 

[My Aswer Is This]

And here is a script I wrote which just adds new sheets.

You would need to create a sheet named "Add"

Then enter the sheet names you want new sheets created for in column "A"
Then when you run the script new sheets would be created for you.

Sub Add_sheets()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Sheets("Add").Activate
Lastrow = Sheets("Add").Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To Lastrow
        ans = Cells(i, 1).Value
        ThisWorkbook.Worksheets.Add(after:=Sheets(Sheets.Count)).Name = Sheets("Add").Cells(i, 1).Value
        Sheets("Sheet1").Rows(1).Copy ActiveSheet.Rows(1)
    Next
Application.ScreenUpdating = True
End Sub

 

[billandrew]

Does work a bit slow none the less it does work... Added the Header row from code you provide in an earlier post

Thank you....