Solved

Excel Macro to copy rows into new tabs based on values in column J - Subscript out of Range?

Posted on 2012-04-03
10
436 Views
Last Modified: 2012-04-04
Hi, I found the following code online to copy rows into new tabs based on values in column A (which I changed to J). When I run it, it seems to do what I want it to do, except I get a 'Subscript out of range' error when it creates a blank 'Sheet74'. I think it's trying to create a new tab when there isn't any data to copy and paste? There shouldn't be a tab named Sheet74...

I get the error on this line:
Set Targetsht = ActiveWorkbook.Worksheets(CurrentCellValue)


In my sheet, I'm pasting columns A-Q based on the names found in column J into new tabs. I would like to also paste the header A1-Q1 row into all tabs, but I haven't been able to get that far. Here is what I have...



Sub CopyRowsToSheets()

'copy rows to worksheets based on value in column J

'assume the worksheet name to paste to is the value in Col J

Dim CurrentCell As Range
Dim SourceRow As Range
Dim Targetsht As Worksheet
Dim TargetRow As Long
Dim CurrentCellValue As String

'start with cell A2 on "Master" sheet
Set CurrentCell = Worksheets("Surface-SignedOut_3-26-2012").Cells(2, "J") 'row ... column ...

Do While Not IsEmpty(CurrentCell)
CurrentCellValue = CurrentCell.Value
Set SourceRow = CurrentCell.EntireRow

'Check if worksheet exists
On Error Resume Next

Testwksht = Worksheets(CurrentCellValue).Name

If Err.Number = 0 Then

'MsgBox CurrentCellValue & " worksheet Exists"
Else

'MsgBox "Adding a new worksheet for " & CurrentCellValue'


Worksheets.Add.Name = CurrentCellValue

End If

On Error GoTo 0 'reset on error to trap errors again


Set Targetsht = ActiveWorkbook.Worksheets(CurrentCellValue)


' Find next blank row in Targetsht - check using Column J'
TargetRow = Targetsht.Cells(Rows.Count, "J").End(xlUp).Row + 1
SourceRow.Copy Destination:=Targetsht.Cells(TargetRow, 1)

'do the next cell
Set CurrentCell = CurrentCell.Offset(1, 0)

Loop

End Sub
Sub copytoall() 'works from anywhere in the workbook.
For Each ws In Worksheets
If ws.Name <> "Surface-SignedOut_3-26-2012" Then _
Sheets("Surface-SignedOut_3-26-2012").Cells(1, 1).End(xlDown). _
EntireRow.Copy ws.Range("a1")
Next ws
End Sub

Thanks
0
Comment
Question by:mskitten
  • 5
  • 5
10 Comments
 
LVL 14

Expert Comment

by:Zack Barresse
ID: 37802292
Hi there,

Your error is probably due to one of two reasons, 1) the cell is blank, thus no name given, or 2) a bad sheet name, i.e. bad characters not allowed in a sheet.

Here is your code somewhat simplified:
Sub CopyRowsToSheets()

    'copy rows to worksheets based on value in column J
    'assume the worksheet name to paste to is the value in Col J
    
    Dim CurrentCell As Range
    Dim Targetsht As Worksheet
    
    Call TOGGLEEVENTS(False)
    With Worksheets("Surface-SignedOut_3-26-2012")
        For Each CurrentCell In .Range(.Cells(2, "J"), .Cells(.Rows.Count, "J").End(xlUp))
            If WSEXISTS(CurrentCell.Value, ThisWorkbook) = False Then
                Set Targetsht = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
                On Error Resume Next
                Targetsht.Name = CurrentCell.Value
                If Err.Number <> 0 Then
                    'bad sheet name
                    Err.Clear
                End If
                On Error GoTo 0
                CurrentCell.EntireRow.Copy Targetsht.Rows(1)
            End If
        Next CurrentCell
    End With
    Call TOGGLEEVENTS(True)
    
End Sub

Function WSEXISTS(wksName As String, Optional WKB As Workbook) As Boolean
    If WKB Is Nothing Then
        If ActiveWorkbook Is Nothing Then Exit Function
        Set WKB = ActiveWorkbook
    End If
    On Error Resume Next
    WSEXISTS = CBool(WKB.Worksheets(wksName).Name <> "")
    On Error GoTo 0
End Function

Sub TOGGLEEVENTS(blnState As Boolean)
    Application.ScreenUpdating = blnState
    Application.EnableEvents = blnState
    Application.DisplayAlerts = blnState
    If blnState Then Application.CutCopyMode = blnState
    If blnState Then Application.StatusBar = blnState
End Sub

Open in new window


What this does not do is take any value if it's a bad sheet name and parse out any bad characters.  If you would like that functionality, we can add it, either way.

HTH

Regards,
Zack Barresse
0
 

Author Comment

by:mskitten
ID: 37802751
Hi Zack, I get a type mismatch error at this line:

If WSEXISTS(CurrentCell.Value, ThisWorkbook) = False Then

I also notice that the tabs it did create, only copied one row (there should be many rows per name).

I did notice some bad characters and removed them. Maybe it doesn't recognize the last row? I checked for blanks, and did not see any.

Thanks
0
 
LVL 14

Expert Comment

by:Zack Barresse
ID: 37803025
Did you copy the WSEXISTS() routine as well?  There is currently no test on passing the variable, so all error handling should be done in the function itself.  When you hit Debug and step through the code with the F8 key, what line gets the error?

I also notice that the tabs it did create, only copied one row (there should be many rows per name).
In reading your code, that seemed to be all it was doing.  What else do you want it to do?  It should be copying the current row iteration and pasting it on row 1 of the destination (newly created) worksheet.

I did notice some bad characters and removed them. Maybe it doesn't recognize the last row? I checked for blanks, and did not see any.
This code should dynamically go from row 2 in column J to the last cell in column J with data in it:
For Each CurrentCell In .Range(.Cells(2, "J"), .Cells(.Rows.Count, "J").End(xlUp))

Open in new window


Zack
0
 

Author Comment

by:mskitten
ID: 37803888
Hi Zack, I just ran it again, and it worked, except only copying one row of data per name, when there should be multiple rows copied per name. For example

A ......... J
1          Sam
4          Jenny
2          Jenny
3          Edward
8          Sam
1          Jenny

For the Sam tab there should be 2 rows, for Jenny 3 rows, and Edward only 1 row. Hope that helps?
0
 
LVL 14

Accepted Solution

by:
Zack Barresse earned 500 total points
ID: 37804124
It helps, and it changes circumstances quite a bit.  You could use this amended code.  You would still need the other two with it though...

Sub CopyRowsToSheets()
    
    Dim rCheck As Range
    Dim rFilter As Range
    Dim cUnique As New Collection
    Dim i As Long
    Dim CurrentCell As Range
    Dim Targetsht As Worksheet
    
    Call TOGGLEEVENTS(False)
    With Worksheets("Surface-SignedOut_3-26-2012")
        Set rCheck = .Range(.Cells(1, "J"), .Cells(.Rows.Count, "J").End(xlUp))
        Set rFilter = .Range(.Cells(2, "J"), .Cells(.Rows.Count, "J").End(xlUp))
        On Error Resume Next
        For Each CurrentCell In rFilter.Cells
            cUnique.Add CurrentCell.Value, CurrentCell.Value
        Next CurrentCell
        On Error GoTo 0
    End With
    
    For i = 1 To cUnique.Count
        
        If WSEXISTS(cUnique(i), ThisWorkbook) = False Then
            Set Targetsht = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            On Error Resume Next
            Targetsht.Name = cUnique(i)
            If Err.Number <> 0 Then
                'bad sheet name
                Err.Clear
            End If
            On Error GoTo 0
            On Error Resume Next
            rCheck.AutoFilter Field:=1, Criteria1:=cUnique(i)
            rFilter.SpecialCells(xlCellTypeVisible).EntireRow.Copy Targetsht.Rows(1)
            rCheck.Parent.AutoFilterMode = False
            On Error GoTo 0
        End If
                
    Next i
    
    Call TOGGLEEVENTS(True)
    
End Sub

Open in new window


HTH

Regards,
Zack
0
Top 6 Sources for Identifying Threat Actor TTPs

Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

 

Author Comment

by:mskitten
ID: 37806678
Hi Zack, that works great! I was wondering though, how can I paste the header from the original sheet, into all the other sheets? Also, is there a way to order the tabs alphabatically?
Thanks again for your help
0
 
LVL 14

Assisted Solution

by:Zack Barresse
Zack Barresse earned 500 total points
ID: 37807791
LOL!  Scope creep!  LOL!  I jest, but honestly jest.  This is what we call scope creep.  And not that I mind, but it's easier to get it all out of the way in your initial question, rather than a lot of little questions.  I do understand hind-sight though.  I've just seen this a LOT, hence my brevity of it.  :)

If you want the header from the original sheets, you just need to add that line.  You would also need to start the copy of filtered data to row 2 instead of 1 then.  There's one line of code which will be altered and another added.

Sub CopyRowsToSheets()
    
    Dim rCheck As Range
    Dim rFilter As Range
    Dim cUnique As New Collection
    Dim i As Long
    Dim CurrentCell As Range
    Dim Targetsht As Worksheet
    
    Call TOGGLEEVENTS(False)
    With Worksheets("Surface-SignedOut_3-26-2012")
        Set rCheck = .Range(.Cells(1, "J"), .Cells(.Rows.Count, "J").End(xlUp))
        Set rFilter = .Range(.Cells(2, "J"), .Cells(.Rows.Count, "J").End(xlUp))
        On Error Resume Next
        For Each CurrentCell In rFilter.Cells
            cUnique.Add CurrentCell.Value, CurrentCell.Value
        Next CurrentCell
        On Error GoTo 0
    End With
    
    For i = 1 To cUnique.Count
        
        If WSEXISTS(cUnique(i), ThisWorkbook) = False Then
            Set Targetsht = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            On Error Resume Next
            Targetsht.Name = cUnique(i)
            If Err.Number <> 0 Then
                'bad sheet name
                Err.Clear
            End If

            '/// Added 4-Apr-12
            '/// Copy header row on top of other data
            rCheck(1, 1).EntireRow.Copy Targetsht.Rows(1)

            rCheck.AutoFilter Field:=1, Criteria1:=cUnique(i)
            rFilter.SpecialCells(xlCellTypeVisible).EntireRow.Copy Targetsht.Rows(2)
            rCheck.Parent.AutoFilterMode = False
        End If
        
        On Error GoTo 0
                
    Next i
    
    Call TOGGLEEVENTS(True)
    
End Sub

Open in new window



For sorting worksheets by name, take a look at Chip Pearson's website: http://www.cpearson.com/excel/sortws.aspx

Here is the function of Chip's for you:

Public Function SortWorksheetsByName(ByVal FirstToSort As Long, _
                            ByVal LastToSort As Long, _
                            ByRef ErrorText As String, _
                            Optional ByVal SortDescending As Boolean = False, _
                            Optional ByVal Numeric As Boolean = False) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SortWorksheetsByName
' This sorts the worskheets from FirstToSort to LastToSort by name
' in either ascending (default) or descending order. If successful,
' ErrorText is vbNullString and the function returns True. If
' unsuccessful, ErrorText gets the reason why the function failed
' and the function returns False. If you include the Numeric
' parameter and it is True, (1) all sheet names to be sorted
' must be numeric, and (2) the sort compares names as numbers, not
' text.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim M As Long
Dim N As Long
Dim WB As Workbook
Dim B As Boolean

Set WB = Worksheets.Parent
ErrorText = vbNullString

If WB.ProtectStructure = True Then
    ErrorText = "Workbook is protected."
    SortWorksheetsByName = False
End If
    
'''''''''''''''''''''''''''''''''''''''''''''''
' If First and Last are both 0, sort all sheets.
''''''''''''''''''''''''''''''''''''''''''''''
If (FirstToSort = 0) And (LastToSort = 0) Then
    FirstToSort = 1
    LastToSort = WB.Worksheets.Count
Else
    '''''''''''''''''''''''''''''''''''''''
    ' More than one sheet selected. We
    ' can sort only if the selected
    ' sheet are adjacent.
    '''''''''''''''''''''''''''''''''''''''
    B = TestFirstLastSort(FirstToSort, LastToSort, ErrorText)
    If B = False Then
        SortWorksheetsByName = False
        Exit Function
    End If
End If

If Numeric = True Then
    For N = FirstToSort To LastToSort
        If IsNumeric(WB.Worksheets(N).Name) = False Then
            ' can't sort non-numeric names
            ErrorText = "Not all sheets to sort have numeric names."
            SortWorksheetsByName = False
            Exit Function
        End If
    Next N
End If

'''''''''''''''''''''''''''''''''''''''''''''
' Do the sort, essentially a Bubble Sort.
'''''''''''''''''''''''''''''''''''''''''''''
For M = FirstToSort To LastToSort
    For N = M To LastToSort
        If SortDescending = True Then
            If Numeric = False Then
                If StrComp(WB.Worksheets(N).Name, WB.Worksheets(M).Name, vbTextCompare) > 0 Then
                    WB.Worksheets(N).Move before:=WB.Worksheets(M)
                End If
            Else
                If CLng(WB.Worksheets(N).Name) > CLng(WB.Worksheets(M).Name) Then
                    WB.Worksheets(N).Move before:=WB.Worksheets(M)
                End If
            End If
        Else
            If Numeric = False Then
                If StrComp(WB.Worksheets(N).Name, WB.Worksheets(M).Name, vbTextCompare) < 0 Then
                    WB.Worksheets(N).Move before:=WB.Worksheets(M)
                End If
            Else
                If CLng(WB.Worksheets(N).Name) < CLng(WB.Worksheets(M).Name) Then
                    WB.Worksheets(N).Move before:=WB.Worksheets(M)
                End If
            End If
        End If
    Next N
Next M

SortWorksheetsByName = True

End Function

Open in new window

0
 

Author Comment

by:mskitten
ID: 37808683
Actually, I think this is all I need. Thank you both Zack and firefytr!
0
 

Author Closing Comment

by:mskitten
ID: 37808689
Thank you both
0
 
LVL 14

Expert Comment

by:Zack Barresse
ID: 37808760
Mskitten,  I apologize for the confusion, I am Zack and firefytr.  "firefytr" is my online moniker for this forum, but my name is Zack.  I know, I like to make things confusing.  :)

Regards,
Zack (aka firefytr)
0

Featured Post

Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

When trying to find the cause of a problem in VBA or VB6 it's often valuable to know what procedures were executed prior to the error. You can use the Call Stack for that but it is often inadequate because it may show procedures you aren't intereste…
This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now