Dynamic Cut and Paste VBA

jdb2313

New Member
Joined
Oct 19, 2018
Messages
7
I am very new to vba and some help creating a code. I need to cut each unique Name record and paste it into it's own new sheet. I tried to find an existing code but had no luck. Can someone help me with this?
[TABLE="width: 192"]
<colgroup><col width="64" span="3" style="width:48pt"> </colgroup><tbody>[TR]
[TD="width: 64"]Name[/TD]
[TD="width: 64"]Title[/TD]
[TD="width: 64"]Location[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD]admin[/TD]
[TD]NC[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD]admin[/TD]
[TD]NC[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD]Mgmt[/TD]
[TD]NC[/TD]
[/TR]
[TR]
[TD]Steve[/TD]
[TD]admin[/TD]
[TD]SC[/TD]
[/TR]
[TR]
[TD]Steve[/TD]
[TD]admin[/TD]
[TD]SC[/TD]
[/TR]
[TR]
[TD]Scott[/TD]
[TD]Mgmt[/TD]
[TD]MD[/TD]
[/TR]
[TR]
[TD]Scott[/TD]
[TD]admin[/TD]
[TD]MD[/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Assuming all the new sheets have been created
And assuming The list of sheet names are in column A of Sheet(1) starting in Row(2)
And this script copies the row to it's proper sheet. It does not cut it.

Run this script from the master sheet.

If these assumptions are not correct please provide specific details

Code:
Sub Copy_Row_To_Sheet_Cell_Value()
Application.ScreenUpdating = False
'Modified  10/19/2018  9:29:34 PM  EDT
On Error GoTo M
Dim i As Long
Sheets("Sheet1").Activate
Dim Lastrow As Long
Lastrow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
Dim Lastrowa As Long
Dim ans As String
    For i = 2 To Lastrow
    
   With Sheets(1)
    
    If .Cells(i, "A").Value <> "" Then
    ans = .Cells(i, "A").Value
    Lastrowa = Sheets(ans).Cells(Rows.Count, "A").End(xlUp).Row + 1
    .Rows(i).Copy Destination:=Sheets(ans).Rows(Lastrowa)
    End If
    
End With
Next
Exit Sub
M:
MsgBox "You do not have a sheet named  " & ans
End Sub
 
Upvote 0
So you would have 3 sheets, one named Mike, another Steve and the third named Scott
 
Last edited:
Upvote 0
Hi & welcome to MrExcel.

This will create the sheets and then copy the data across
Code:
Sub SplitToSheet()
   Dim Cl As Range
   Dim Ws As Worksheet
   
   Set Ws = Sheets("Sheet1")
   If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then
            .add Cl.Value, Nothing
            Sheets.add(, Ws).Name = Cl.Value
            Ws.Range("A1").AutoFilter 1, Cl.Value
            Ws.UsedRange.SpecialCells(xlVisible).Copy Sheets(Cl.Value).Range("A1")
         End If
      Next Cl
   End With
   Ws.AutoFilterMode = False
End Sub
 
Last edited:
Upvote 0

Forum statistics

Threads
1,223,887
Messages
6,175,199
Members
452,617
Latest member
Narendra Babu D

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top