Results 1 to 9 of 9
  1. #1
    New Lounger
    Join Date
    Sep 2015
    Posts
    9
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Creating sheets and copying data

    Hi, I am trying to use the data in "A2" (numbers) to create new sheets in my workbook. Then copy the data from from the corresponding rows into the right sheet.
    Example:
    In my main sheet named "owssrv", "A2" through "A7" values are 2,3,4,5,6.
    When I run my macro, I create sheets named "2", "3", "4", "5" and "6"
    The information located in "owssrv" in B2 through B4,C2 throughC4, D2 through D4 and so on of each row needs to be copied to the corresponding sheet based on the values found in column A starting at 2.

    The number of rows available to create new sheets in column A is unlimited.

    I have a macro to create my new sheets but do not know how to copy and paste the data into the correct sheet.

    Any ideas?

  2. #2
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,434
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Tim,

    A picture or better yet a sample workbook would be a lot of help here.
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  3. #3
    New Lounger
    Join Date
    Sep 2015
    Posts
    9
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Example.jpg

    Column A has the numbers I use to create the sheets.

  4. #4
    New Lounger
    Join Date
    Sep 2015
    Posts
    9
    Thanks
    0
    Thanked 0 Times in 0 Posts
    I want to copy the data from columns B.C and D into the corresponding new sheets that were created using column A.
    B2,C2 and D2 into Sheet 5. B3,C3 and D3 into sheet 6 and so on.

  5. #5
    New Lounger
    Join Date
    Sep 2015
    Posts
    9
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Here is my script:
    Option Explicit

    Sub CreateSheetsFromAList()
    Dim nameSource As String 'sheet name where to read names
    Dim nameColumn As String 'column where the names are located
    Dim nameStartRow As Long 'row from where name starts

    Dim Sheet As String 'sheet name
    Dim Range As String 'range to copy from data sheet

    Dim nameEndRow As Long 'row where name ends
    Dim SheetName As String 'ID

    Dim newSheet As Worksheet

    nameSource = "owssrv"
    nameColumn = "A"
    nameStartRow = 2

    Sheet = "owssrv"
    Range = "B" 'for example this is range we are going to copy
    'remove any white space

    'find the last cell in use
    nameEndRow = Sheets(nameSource).Cells(Rows.Count, nameColumn).End(xlUp).Row

    'loop till last row
    Do While (nameStartRow <= nameEndRow)
    'get the name
    SheetName = Sheets(nameSource).Cells(nameStartRow, nameColumn)

    SheetName = Trim(SheetName)

    ' if name is not equal to ""
    If (SheetName <> vbNullString) Then

    On Error Resume Next 'do not throw error
    Err.Clear 'clear any existing error

    'if sheet name is not present this will cause error that we are going to leverage
    Sheets(SheetName).Name = SheetName

    If (Err.Number > 0) Then
    'sheet was not there, so it create error, so we can create this sheet
    Err.Clear
    On Error GoTo -1 'disable exception so to reuse in loop

    'add new sheet
    Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))

    'rename sheet
    newSheet.Name = SheetName


    Application.CutCopyMode = False 'clear clipboard
    'copy data
    Sheets(Sheet).Range(Range).Copy

    'paste data
    Sheets(SheetName).Cells(1, "A").PasteSpecial
    Application.CutCopyMode = False
    End If
    End If
    nameStartRow = nameStartRow + 1 'increment row
    Loop
    End Sub

  6. #6
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,434
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Tim,

    Give this a try:
    Code:
    Option Explicit
    
    Sub CreateNumberedSheets()
    
       Dim lCurRow   As Long
       Dim shtMstr   As Worksheet
       Dim shtTarget As Worksheet
       Dim zShtName  As String
       Dim zNewSht   As String
       Dim iAns      As Integer
       
    
       lCurRow = 2
       Set shtMstr = ActiveSheet
       
       Do
       
         zNewSht = Format(Cells(lCurRow, 1), "#")
         On Error Resume Next
         zShtName = Sheets(zNewSht).Name
         On Error GoTo 0
         
         If zShtName = "" Then
         
           Set shtTarget = Sheets.Add(After:=Sheets(Sheets.Count))
           shtTarget.Name = zNewSht
           shtMstr.Activate         'Excel wants source active?
           shtMstr.Range(Cells(lCurRow, 2), Cells(lCurRow, 4)).Copy _
                Destination:=shtTarget.Range("A1")
         Else
           iAns = MsgBox("Sheet: " & zNewSht & " already Exists!", _
                         vbOKCancel + vbExclamation, _
                         "Possible Error:")
           If iAns = vbOK Then
             '*** Copy anyway! ***
             shtMstr.Activate         'Excel wants source active?
             shtMstr.Range(Cells(lCurRow, 2), Cells(lCurRow, 4)).Copy _
                               Destination:=Sheets(zShtName).Range("A1")
           Else
             '*** Error handling here ***
           End If
           
         End If
         
         lCurRow = lCurRow + 1    '*** Move to next row ***
       
       Loop Until Cells(lCurRow, 1).Value = ""
       
       
    End Sub  'CreateNumberedSheets
    Remember to try on a COPY of your workbook!

    HTH
    Last edited by RetiredGeek; 2015-09-10 at 15:12.
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  7. #7
    New Lounger
    Join Date
    Sep 2015
    Posts
    9
    Thanks
    0
    Thanked 0 Times in 0 Posts
    This works great! Thank you! Is there a way to set the column widths so that the information displays properly?

  8. #8
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,434
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Tim,

    Code:
    Option Explicit
    
    Sub CreateNumberedSheets()
    
       Dim lCurRow   As Long
       Dim shtMstr   As Worksheet
       Dim shtTarget As Worksheet
       Dim zShtName  As String
       Dim zNewSht   As String
       Dim iAns      As Integer
       
    
       lCurRow = 2
       Set shtMstr = ActiveSheet
       
       Do
       
         zNewSht = Format(Cells(lCurRow, 1), "#")
         On Error Resume Next
         zShtName = Sheets(zNewSht).Name
         On Error GoTo 0
         
         If zShtName = "" Then
         
           Set shtTarget = Sheets.Add(After:=Sheets(Sheets.Count))
           shtTarget.Name = zNewSht
           shtMstr.Activate         'Excel wants source active?
           shtMstr.Range(Cells(lCurRow, 2), Cells(lCurRow, 4)).Copy _
                Destination:=shtTarget.Range("A1")
           shtTarget.Columns("A:D").EntireColumn.AutoFit
         Else
           iAns = MsgBox("Sheet: " & zNewSht & " already Exists!", _
                         vbOKCancel + vbExclamation, _
                         "Possible Error:")
           If iAns = vbOK Then
             '*** Copy anyway! ***
             shtMstr.Activate         'Excel wants source active?
             shtMstr.Range(Cells(lCurRow, 2), Cells(lCurRow, 4)).Copy _
                               Destination:=Sheets(zShtName).Range("A1")
             Sheets(zShtName).Columns("A:D").EntireColumn.AutoFit
           Else
             '*** Error handling here ***
           End If
           
         End If
         
         lCurRow = lCurRow + 1    '*** Move to next row ***
       
       Loop Until Cells(lCurRow, 1).Value = ""
       
       
    End Sub  'CreateNumberedSheets
    Please note that this adjustment will widen the column. It will not make it wrap. If you want that you'll have to set a column width then set the column to wrap. I assume you'll only want to do this with Column C?
    Code:
    Option Explicit
    
    Sub CreateNumberedSheets()
    
       Dim lCurRow   As Long
       Dim shtMstr   As Worksheet
       Dim shtTarget As Worksheet
       Dim zShtName  As String
       Dim zNewSht   As String
       Dim iAns      As Integer
       
    
       lCurRow = 2
       Set shtMstr = ActiveSheet
       
       Do
       
         zNewSht = Format(Cells(lCurRow, 1), "#")
         On Error Resume Next
         zShtName = Sheets(zNewSht).Name
         On Error GoTo 0
         
         If zShtName = "" Then
         
           Set shtTarget = Sheets.Add(After:=Sheets(Sheets.Count))
           shtTarget.Name = zNewSht
           shtMstr.Activate         'Excel wants source active?
           shtMstr.Range(Cells(lCurRow, 2), Cells(lCurRow, 4)).Copy _
                Destination:=shtTarget.Range("A1")
             With shtTarget
                 .Columns("A:C").VerticalAlignment = xlTop
                 .Columns("A:B").EntireColumn.AutoFit
                 .Columns("C").ColumnWidth = 10   '*** Adjust as appropriate ***
                 .Columns("C").WrapText = True
             End With
         Else
           iAns = MsgBox("Sheet: " & zNewSht & " already Exists!", _
                         vbOKCancel + vbExclamation, _
                         "Possible Error:")
           If iAns = vbOK Then
             '*** Copy anyway! ***
             shtMstr.Activate         'Excel wants source active?
             shtMstr.Range(Cells(lCurRow, 2), Cells(lCurRow, 4)).Copy _
                               Destination:=Sheets(zShtName).Range("A1")
             With Sheets(zShtName)
                 .Columns("A:C").VerticalAlignment = xlTop
                 .Columns("A:B").EntireColumn.AutoFit
                 .Columns("C").ColumnWidth = 10   '*** Adjust as above ***
                 .Columns("C").WrapText = True
             End With
           Else
             '*** Error handling here ***
           End If
           
         End If
         
         lCurRow = lCurRow + 1    '*** Move to next row ***
       
       Loop Until Cells(lCurRow, 1).Value = ""
       
       
    End Sub  'CreateNumberedSheets
    Tim.JPG

    HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  9. #9
    New Lounger
    Join Date
    Sep 2015
    Posts
    9
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Awesome! Thanks again!

Posting Permissions

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