Helps with Excel or Programming! Need to move rows to a separate tab

KimJ

New member
Joined
May 1, 2020
Messages
3
Reaction score
0
Points
0
Excel Version(s)
Excel 2016
Hi, newbie and needs help. i have a master worksheet with multiple rows and columns of information. Need to create new worksheet based on unique id in the 1st column and then port over the rows of information into the new worksheet created. i have attached the excel worksheet. thank you.
 

Attachments

  • Lab Database.xlsm
    26.5 KB · Views: 15
.
Code:
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]mmm;@"))


                ' 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]mmm;@")
                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]mmm;@")
        Sheets("Sheet1").Rows(i).Copy Sheets(ans2).Rows(Sheets(ans2).Cells(Rows.Count, "A").End(xlUp).Row + 1)
        Sheets(ans2).Columns("A:H").AutoFit
    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
 
Back
Top