code to automate

[iksotof]

Hello

I am looking for some code that I could put onto a button to automate the following workbook. I have the source data as in the first tab but need to reorder it, create the following three tabs, based on the subsequent following three tabs, with the tabs labelled and orderd in aplha ordr base on the colum header scheme name (scheme). The data in the exanple is a limited mock up and in reality I could have many lines of data. any ideas would be enormously helpful.


Kind regards Darren.

[HansV]

Does this do what you want?

Code: Select all

Sub SplitData()
    Dim wshS As Worksheet
    Dim wshT As Worksheet
    Dim r As Long
    Dim m As Long
    Dim strName As String
    Application.ScreenUpdating = False
    ' Source sheet
    Set wshS = Worksheets("Group_Collections_IM_Dowload")
    ' Sort on column A
    wshS.UsedRange.Sort Key1:=wshS.Range("A1"), Header:=xlYes
    ' Last row
    m = wshS.Range("A" & wshS.Rows.Count).End(xlUp).Row
    ' Loop
    For r = 2 To m
        strName = wshS.Range("A" & r).Value
        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets(strName).Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
        Set wshT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        wshT.Name = strName
        wshT.Range("A1:G1").Value = Array("IM Notional Account", "Client Names (Member)", _
            "Amber Account", "Collection Date", "Type", "Expenditure", "Description")
        wshS.Range("A1").Copy
        wshT.Range("A1:G1").PasteSpecial Paste:=xlPasteFormats
        wshS.Range("B" & r & ":E" & r).Copy Destination:=wshT.Range("A2:D3")
        wshT.Range("E2").Value = "fruit"
        wshS.Range("F" & r).Copy Destination:=wshT.Range("G2")
        wshT.Range("E3").Value = "veg"
        wshS.Range("G" & r).Copy Destination:=wshT.Range("G3")
        wshS.Range("H" & r).Copy Destination:=wshT.Range("F2:F3")
        wshT.Range("A1:G1").EntireColumn.AutoFit
    Next r
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

[iksotof]

Wow, thanks Hans, it works gloriously with the mock up. I am having an error: eun-time 1004, application defined or object defined error on my realife example, I have change some of the values in the headers as I think are appropriate but to avail (see below- fruit and veg have been changed to employee contribition and employer contribution respectively) have been changed. I have attacched an example of my real time file for ref.

May thanks

Code: Select all

Sub SplitData()
    Dim wshS As Worksheet
    Dim wshT As Worksheet
    Dim r As Long
    Dim m As Long
    Dim strName As String
    Application.ScreenUpdating = False
    ' Source sheet
    Set wshS = Worksheets("Group_Collections_IM_Dowload")
  ' Sort on column A
    wshS.UsedRange.Sort Key1:=wshS.Range("A1"), Header:=xlYes
    ' Last row
    m = wshS.Range("A" & wshS.Rows.Count).End(xlUp).Row
    ' Loop
    For r = 2 To m
        strName = wshS.Range("A" & r).Value
        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets(strName).Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
        Set wshT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        wshT.Name = strName
        wshT.Range("A1:G1").Value = Array("IM Notional Account", "Client Names (Member)", _
            "Amber Account", "Collection Date", "Type", "Expenditure", "Description")
        wshS.Range("A1").Copy
        wshT.Range("A1:G1").PasteSpecial Paste:=xlPasteFormats
        wshS.Range("B" & r & ":E" & r).Copy Destination:=wshT.Range("A2:D3")
        wshT.Range("E2").Value = "Employee Contribution"
        wshS.Range("F" & r).Copy Destination:=wshT.Range("G2")
        wshT.Range("E3").Value = "Employer Contribution"
        wshS.Range("G" & r).Copy Destination:=wshT.Range("G3")
        wshS.Range("H" & r).Copy Destination:=wshT.Range("F2:F3")
        wshT.Range("A1:G1").EntireColumn.AutoFit
    Next r
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

[HansV]

The macro runs without errors in the new workbook that you attached, so I can't tell why you would get an error message.

[Rudi]

I too ran it a few times without error earlier, so instead of commenting I thought I'd wait for Hans to verify...

[iksotof]

Hello Guys

Apologies for the late, late reply. I have been on vacation, it does indeed work. I have since learned that it is to do with string length for the tab names, some of my nameds are in excess of 30 characters and I have now amendeded to find these work.

Thanks again

Darren

[iksotof]

Sorry guys

On further inspection, it is working but only returning two lines of data for each tab? What may be arresting that? For example have a scheme value Knd that has 4 entries on the first tab but only two are returned in the tab for Knd.


Thank you.

[HansV]

Could you post a workbook that demonstrates the problem?

[iksotof]

Thanks Hans


Here is one that I just run...

[HansV]

I see the problem now. The workbook that you attached to the first post in this thread contained only a single row for each scheme name, so the macro that I wrote didn't take multiple rows for the same scheme name into account. The following version does:

Code: Select all

Sub SplitData()
    Dim wshS As Worksheet
    Dim wshT As Worksheet
    Dim r As Long
    Dim m As Long
    Dim t As Long
    Dim strName As String
    Dim strPrevName As String
    Application.ScreenUpdating = False
    ' Source sheet
    Set wshS = Worksheets("Group_Collections_IM_Dowload")
  ' Sort on column A
    wshS.UsedRange.Sort Key1:=wshS.Range("A1"), Header:=xlYes
    ' Last row
    m = wshS.Range("A" & wshS.Rows.Count).End(xlUp).Row
    ' Loop
    For r = 2 To m
        strName = wshS.Range("A" & r).Value
        If strName <> strPrevName Then
            On Error Resume Next
            Application.DisplayAlerts = False
            Worksheets(strName).Delete
            Application.DisplayAlerts = True
            On Error GoTo 0
            Set wshT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            wshT.Name = strName
            wshT.Range("A1:G1").Value = Array("IM Notional Account", "Client Names (Member)", _
                "Amber Account", "Collection Date", "Type", "Expenditure", "Description")
            wshS.Range("A1").Copy
            wshT.Range("A1:G1").PasteSpecial Paste:=xlPasteFormats
            t = 2
        End If
        wshS.Range("B" & r & ":E" & r).Copy Destination:=wshT.Range("A" & t).Resize(4, 2)
        wshT.Range("E" & t).Value = "Employee Contribution"
        wshS.Range("F" & r).Copy Destination:=wshT.Range("G" & t)
        wshT.Range("E" & (t + 1)).Value = "Employer Contribution"
        wshS.Range("G" & r).Copy Destination:=wshT.Range("G" & (t + 1))
        wshS.Range("H" & r).Copy Destination:=wshT.Range("F" & t).Resize(2)
        t = t + 2
        strPrevName = strName
    Next r
    wshT.Range("A1:G1").EntireColumn.AutoFit
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

[iksotof]

Thank you Hans


This is sensational, I realise i am being perhaps a little cheeky but I just need it to do a couple fo slight different things, I have tried playing around with the VB but it isn't quite having the desired results. I have posted a further version below. what I would love for it to be able to do is for the columns E and G to be swapped around from those in the lateast coding in the neew sheets that are posted, so instead of colum G with header description and the description data, could this be column E and G " type" be the new column E with its related data? Also on the lines turning my results in the pasted new sheets, could have the all the details replicated on all lines ralting to the the recordm 9see tab ABC?


Mnay thanks Darren.

[HansV]

Try this version:

Code: Select all

Sub SplitData()
    Dim wshS As Worksheet
    Dim wshT As Worksheet
    Dim r As Long
    Dim m As Long
    Dim t As Long
    Dim strName As String
    Dim strPrevName As String
    Application.ScreenUpdating = False
    ' Source sheet
    Set wshS = Worksheets("Group_Collections_IM_Dowload")
  ' Sort on column A
    wshS.UsedRange.Sort Key1:=wshS.Range("A1"), Header:=xlYes
    ' Last row
    m = wshS.Range("A" & wshS.Rows.Count).End(xlUp).Row
    ' Loop
    For r = 2 To m
        strName = wshS.Range("A" & r).Value
        If strName <> strPrevName Then
            If r > 2 Then
                wshT.Range("A1:G1").EntireColumn.AutoFit
            End If
            On Error Resume Next
            Application.DisplayAlerts = False
            Worksheets(strName).Delete
            Application.DisplayAlerts = True
            On Error GoTo 0
            Set wshT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            wshT.Name = strName
            wshT.Range("A1:G1").Value = Array("IM Notional Account", "Client Names (Member)", _
                "Amber Account", "Collection Date", "Contribution", "Expenditure", "Type")
            wshS.Range("A1").Copy
            wshT.Range("A1:G1").PasteSpecial Paste:=xlPasteFormats
            t = 2
        End If
        wshS.Range("B" & r & ":E" & r).Copy Destination:=wshT.Range("A" & t).Resize(2, 4)
        wshT.Range("G" & t).Value = "Employee Contribution"
        wshS.Range("F" & r).Copy Destination:=wshT.Range("E" & t)
        wshT.Range("G" & (t + 1)).Value = "Employer Contribution"
        wshS.Range("G" & r).Copy Destination:=wshT.Range("E" & (t + 1))
        wshS.Range("H" & r).Copy Destination:=wshT.Range("F" & t).Resize(2)
        t = t + 2
        strPrevName = strName
    Next r
    wshT.Range("A1:G1").EntireColumn.AutoFit
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

[iksotof]

Fnatatsic Hans


thank you