Help with Macro that generates a tab per unique name in list within a table

[edmundmckay]

Hello

I am looking for some guidance on the below Macro. I have a table (Table1) on a tab named "Arrears Report". The table has a list of property names on it and their arrears. The table has 15 columns.

I am looking to generate a tab Per Property Name with the corresponding data for the property extracted from a table with header as per the table below. There are around 70 properties.

In the below macro I have typed number 2 as column reference. in the macro this is labelled as vcol. The macro works by generating the 70 tabs off the table. What it isn't doing is picking up all the properties in the list in column 2. Where there are properties which begin with the same name but have a different property code after, it generates a number blank sheet. In the below data with Burgess Hill Property Name it generates Burgess Hill (200400) as its own tab but creates Sheet3 with no data for Burgess Hill High Street (200201).

Could anyone help with updating the macro in order that the above problem doesn't happen?

Property

Property Name

Charge To Invoice

Invoice No

Charge Code<strike></strike>

Invoice<strike></strike>

From Date<strike></strike>

To Date<strike></strike>

Total Charges<strike></strike>

Total Owed<strike></strike>

Accumulated<strike></strike>

Comments<strike></strike>

NRR Feed Back<strike></strike>

PM Feedback<strike></strike>

200400

Burgess Hill (200400) <tbody> </tbody> <strike></strike>

*****

*****<strike></strike>

*****

*****<strike></strike>

*****

*****<strike></strike>

*****

*****<strike></strike>

*****

*****<strike></strike>

*****

*****<strike></strike>

200400 <tbody> </tbody> <strike></strike>

Burgess Hill (200400) <tbody> </tbody> <strike></strike>

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

200400 <tbody> </tbody> <strike></strike>

Burgess Hill (200400) <tbody> </tbody> <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

200201 <tbody> </tbody> <strike></strike>

Burgess Hill High Street (200201) <tbody> </tbody> <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

200201 <tbody> </tbody> <strike></strike>

Burgess Hill High Street (200201) <tbody> </tbody> <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

149400 <tbody> </tbody> <strike></strike>

Erdington (149400) <tbody> </tbody> <strike></strike>

*****

***** <strike></strike>

***** <strike></strike>

***** <strike></strike>

***** <strike></strike>

***** <strike></strike>

***** <strike></strike>

***** <strike></strike>

***** <strike></strike>

***** <strike></strike>

***** <strike></strike>

***** <strike></strike>

149400 <tbody> </tbody> <strike></strike>

Erdington (149400) <tbody> </tbody> <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

*****

***** <strike></strike>

<tbody>
</tbody>

Macro code:

Sub splitpropertyintotabsmacro()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Dim LR As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 2
Set ws = Sheets("Arrears Report")
LR = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A14:S14"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 15 To LR
On Error Resume Next
If ws.Cells(i, vcol) <> "()" & "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & LR).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
'Delete Total Tab'
'Stopping Application Alerts
Application.DisplayAlerts = False
Sheets("Total").Delete

'Enabling Application alerts once we are done with our task
Application.DisplayAlerts = True
Sheets("Arrears Report").Select
ActiveSheet.ListObjects(1).AutoFilter.ShowAllData
Range("A1").Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True

End Sub

I look forward to any response

many thanks in advance

 

[steve the fish]

Hi. Burgess Hill High Street (200201) is illegal. Length of string is too long. What will you do in this scenario?

 

[edmundmckay]

Hi Steve

Do I need to increase the character length in the below bit of code to resolve this? Perhaps to a number to cover all scenarios like 50?

For i = 15 To LR

 

[steve the fish]

What do you want the sheet names to be? The text without the bracketed number?

 

[steve the fish]

See if this works:

Sub testing()

Dim dic As Object, rng As Variant, i As Long, col As Long, arr, str As String

Set dic = CreateObject("Scripting.Dictionary")

With Sheets("Arrears Report").ListObjects("Table1")
    col = .ListColumns("Property Name").Index
    arr = .ListColumns(col).DataBodyRange
    For i = LBound(arr, 1) To UBound(arr, 1)
        dic(arr(i, 1)) = 1
    Next i
End With

For Each ky In dic.Keys
    If InStr(ky, "(") > 0 Then
        str = Trim(Left(ky, InStr(ky, "(") - 1))
    Else
        str = ky
    End If
    If SheetExists(str) Then
        Sheets(str).Cells.ClearContents
    Else
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = str
    End If
    With Sheets("Arrears Report")
        With .ListObjects("Table1")
            .Range.AutoFilter Field:=col, Criteria1:=ky
            If .Range.Columns(col).SpecialCells(xlCellTypeVisible).Count > 1 Then
                .Range.SpecialCells(xlCellTypeVisible).Copy
                Sheets(str).Range("A1").PasteSpecial xlPasteValues
            End If
            .AutoFilter.ShowAllData
        End With
End With
Next

Application.CutCopyMode = False

End Sub

Function SheetExists(shName As String) As Boolean

Dim sh As Worksheet

On Error Resume Next
Set sh = Sheets(shName)
On Error GoTo 0
SheetExists = Not sh Is Nothing

End Function

 

[edmundmckay]

Firstly thank you Steve for writing a new macro in light of query. I appreciate the time you would have promptly spent on that.

I actually need the full length of text and numbers to be generated on the tabs so no trimming of the list in the Property Name. Including the brackets.

Also I need to maintain the same formatting and look of the table when copying the data into the individual tabs.

When I ran your macro a bug happened;

Error text
Run-time eror '1004':
You typed an invalid name for a sheet or chart. Make sure that:
-The name that you type does not exceed 31 characters
-The name does not contain any of the following characters: :\/?* [or]
-You did not leave the name blank

Relating to below bit of code

Sheets.Add(After:=Sheets(Sheets.Count)).Name = str



The type of text and character varies in the list, not sure if that will change the code too.

(SOLD) Warrington (798900)
* SOLD * 119-121 Ferensway, Hull (448360)
Basingstoke (132100)
Beacon Shopping Centre (639401)
Beacon Shopping Centre Car Park (639416)
Beacon Shopping Centre Phase II (639411)
Beverley (145300)
Blackburn Retail Park (159100)
Blenheim Shopping Centre - Penge (572990)
Boscombe Car Park (166810)
Bradford (173600)
Bridlington (179150)
Broadway Shopping Centre (145650)
Broadway Shopping Centre Car Park (145651)
Broadway Square (145660)
Burgess Hill (200400)
Burgess Hill High Street (200201)
Cardiff Car Park (221700)
Carmarthen (224001)
Chester - Saltney (Ramsay) (235400)
Coalville (248700)
Cornmill Centre, Darlington (281100)
Cowley (658600)
Darlington Car Park (281200)
Doncaster (291600)
East Ham (515900)
Eastham Point Retail Park (195290)
Erdington (149400)
Fareham (343700)
Felixstowe (Homebase) (346110)
Gateshead (354660)

Not sure if this insert URL will keep but this is the format which each tab needs to maintain once copied. The white cells in table are intentional to protect that data publicly.

[/URL]
sulphate structure
[/IMG]

 

[steve the fish]

If you want the sheet names to be the same as the column contents then you need to rid yourself of rows like the below:

* SOLD * 119-121 Ferensway, Hull (448360)

Sheet names cant contain *

Like i said before you cant have more than the allowed number of characters for the sheet name so some names are illegal and therefore cant be used.

 

[edmundmckay]

Thank you Steve. I completely misunderstood your first response. I was so focused within the code to fix and not on the data. I think I will generate a tab column in the table which stays within tab sheet name limit and then use the macro off that.

Thank you for your support and knowledge today. Greatly appreciated.