Results 1 to 2 of 2

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

  1. #1
    Neophyte KimJ's Avatar
    Join Date
    May 2020
    Posts
    3
    Articles
    0
    Excel Version
    Excel 2016

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



    Register for a FREE account, and/
    or Log in to avoid these ads!

    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.
    Attached Files Attached Files

  2. #2
    Conjurer Logit's Avatar
    Join Date
    Nov 2016
    Posts
    277
    Articles
    0
    Excel Version
    2007
    .
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •