Duplicate Rows to New Sheets VBA Error

[cameronb]

The below post has a discussion re duplicate rows being copied to new sheets.

http://www.mrexcel.com/forum/showthread.php?t=328460

The code works fine, until the data it takes to name new sheets exceeds 31 characters.

Is there VBA coding that in naming from this column -
"wsNew.Name = wsCrit.Range("A2")"

can be set to a maximum of 30 characters. If data in the A2 column exceeds this the vba will result in an error.

Sub DistributeRows()
Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim I As Long
    
    Set wsAll = Worksheets(1) ' change 1 to the name of the worksheet the existing data is on
    
    LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row
    
    Set wsCrit = Worksheets.Add
    
    ' column C has the criteria of Custody
    wsAll.Range("C1:C" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
    
    LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
    For I = 2 To LastRowCrit
    
        Set wsNew = Worksheets.Add
        wsNew.Name = wsCrit.Range("A2")
        wsAll.Rows("1:" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
         CopyToRange:=wsNew.Range("A1"), Unique:=False
        wsCrit.Rows(2).Delete
        
    Next I
    
    Application.DisplayAlerts = False
    wsCrit.Delete
    Application.DisplayAlerts = True
    
End Sub

 

[VoG]

Try

Sub DistributeRows()
Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim I As Long
Dim nm As String * 30
    
    Set wsAll = Worksheets(1) ' change 1 to the name of the worksheet the existing data is on
    
    LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row
    
    Set wsCrit = Worksheets.Add
    
    ' column C has the criteria of Custody
    wsAll.Range("C1:C" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
    
    LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
    For I = 2 To LastRowCrit
    
        Set wsNew = Worksheets.Add
        nm = wsCrit.Range("A2")
        wsNew.Name = nm
        wsAll.Rows("1:" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
         CopyToRange:=wsNew.Range("A1"), Unique:=False
        wsCrit.Rows(2).Delete
        
    Next I
    
    Application.DisplayAlerts = False
    wsCrit.Delete
    Application.DisplayAlerts = True
    
End Sub

 

[cameronb]

As ever a speedy response. Ideal, I had tried to set character lenght by using * 30, then realising this can only be used for a string.

Genius - many thanks for this, tested and works!

 

[cameronb]

Just a follow up question, I see you set the string to a fixed value 30, is it possible to set a maximum string length rather than leaving it fixed.

This would allow for a shorter character lenght say 7, being left unaffected?

Many thanks,
cameronb

 

[VoG]

Try

wsNew.Name = Trim(nm)

 

[cameronb]

Why is it that so often, a seemingly complex problem has the most simple solution. I suppose the true definition of lateral thinking!

- Trim function on the variable works a treat, allowing Max characters for the string and deleting spaces as and when!

Many thanks indeed,
Here is to keeping it simple!