Copy/Paste with no blank rows

[craig2525]

Sheet 1 Sheet 2 Sheet 3 Sheet 4

How can I copy/paste the raw data from Sheet 1 to Sheets 2, 3 and 4? I am inputting the raw data into Sheet 1 and would like to automatically copy/paste into separate sheets according to the name in Sheet 1 column 1 (as shown)? I have no experience with VBA.

 

[Logit]

Try this :

Option Explicit

Sub CreateSheetsFromAList()
    Dim myCell As Range, myRange As Range

    Set myRange = Sheets("Sheet1").Range("A2")  'Names List begins at A2
    Set myRange = Range(myRange, myRange.End(xlDown))
Application.ScreenUpdating = False
    For Each myCell In myRange
        
            Sheets.Add after:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = myCell.Value
            Sheets(Sheets.Count).Range("A1").Value = "Category"
            myCell.EntireRow.Copy Sheets(Sheets.Count).Range("A2")
            Sheets(Sheets.Count).Columns("A:A").AutoFit
            myCell.EntireRow.Clear
        
    Next
Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A1").Select
Application.ScreenUpdating = True
End Sub

 

[craig2525]

No experience with VBA so this doesn't make any sense to me. Does this need to be put in each sheet? Where in the formula do I put in Sheet 2, Sheet 3, etc.. Where do I put in the names in the formula? Again this doesn't make sense to me.

 

[Logit]

Right click Sheet1 tab.

Select VIEW CODE

On the menu bar, select INSERT / MODULE

In the large white colored window on the right, paste the above code in its entirety.

Click the X in the Upper Right hand corner. You should now be back on Sheet1.

Click DEVELOPER / INSERT / BUTTON icon in upper left corner of small window that just popped up.

Left click on Sheet1. The button should now be pasted there and a small userform should be in view.

Click on CreateSheetsFromAList and then click on OK.

Now when you click on the button, the macro will run as desired.

 

[craig2525]

 

[Logit]

Which line of code is highlighted ?

 

[craig2525]

 

[Logit]

Try this amended version :

Option Explicit

Sub CreateSheets()

    Dim Cell    As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet

        Set RngBeg = Worksheets("Sheet1").Range("A2")
        Set RngEnd = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp)

        ' Exit if the list is empty.
        If RngEnd.Row < RngBeg.Row Then Exit Sub

        For Each Cell In Worksheets("Sheet1").Range(RngBeg, RngEnd)
            On Error Resume Next
                ' No error means the worksheet exists.
                Set Wks = Worksheets(Cell.Value)

                ' Add a new worksheet and name it.
                If Err <> 0 Then
                    Set Wks = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                    Wks.Name = Cell.Value
                End If
            On Error GoTo 0
        Next Cell

End Sub

Note: The list begins on A2 allowing for a Column Header.

 

[craig2525]

That created all of the sheets perfectly but it didn't copy the information to the sheets. Here is a snip of the information on sheet 1 that needs to be copied to the sheets based on owner. I appreciate the help. It's almost there.

 

[Logit]

This is one method.

Option Explicit

Sub CreateSheets()

    Dim Cell    As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet

        Set RngBeg = Worksheets("Sheet1").Range("A2")
        Set RngEnd = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp)

        ' Exit if the list is empty.
        If RngEnd.Row < RngBeg.Row Then Exit Sub
Application.ScreenUpdating = False
        For Each Cell In Worksheets("Sheet1").Range(RngBeg, RngEnd)
            On Error Resume Next
                ' No error means the worksheet exists.
                Set Wks = Worksheets(Format(Cell.Value, "[$-409]dmmmyy;@"))

                ' Add a new worksheet and name it.
                If Err <> 0 Then
                    Set Wks = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                    Wks.Name = Format(Cell.Value, "[$-409]dmmmyy;@")
                End If
            On Error GoTo 0
        Next Cell
Application.ScreenUpdating = True
MakeHeaders
End Sub

Sub MakeHeaders()
Dim srcSheet As String
Dim dst As Integer
srcSheet = "Sheet1"
Application.ScreenUpdating = False
For dst = 1 To Sheets.Count
    If Sheets(dst).Name <> srcSheet Then
    Sheets(srcSheet).Rows("1:1").Copy
    Sheets(dst).Activate
    Sheets(dst).Range("A1").PasteSpecial xlPasteValues
    'ActiveSheet.PasteSpecial xlPasteValues
    Sheets(dst).Range("A1").Select
    End If
Next
Application.ScreenUpdating = True
CopyData
End Sub

Sub CopyData()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
On Error Resume Next
Lastrow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
Dim ans As String
Dim ans2 As String

NoVisi

    For i = 2 To Lastrow
    ans = Sheets("Sheet1").Cells(i, 1).Value
    ans2 = Format(ans, "[$-409]dmmmyy;@")
        Sheets("Sheet1").Rows(i).Copy Sheets(ans2).Rows(Sheets(ans2).Cells(Rows.Count, "A").End(xlUp).Row + 1)
    Next
    
Visi

Application.ScreenUpdating = True

Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A1").Select

Exit Sub

Application.ScreenUpdating = True

End Sub

Sub NoVisi()
Dim CommandButton1 As Object

CommandButton1.Visible = False

End Sub

Sub Visi()
Dim CommandButton1 As Object

CommandButton1.Visible = True
End Sub

Your command button should activate the CreateSheets sub.