code to automate
-
- 3StarLounger
- Posts: 315
- Joined: 04 May 2010, 15:18
code to automate
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.
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.
You do not have the required permissions to view the files attached to this post.
-
- Administrator
- Posts: 78540
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: code to automate
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
Best wishes,
Hans
Hans
-
- 3StarLounger
- Posts: 315
- Joined: 04 May 2010, 15:18
Re: code to automate
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
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
You do not have the required permissions to view the files attached to this post.
-
- Administrator
- Posts: 78540
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: code to automate
The macro runs without errors in the new workbook that you attached, so I can't tell why you would get an error message.
Best wishes,
Hans
Hans
-
- gamma jay
- Posts: 25455
- Joined: 17 Mar 2010, 17:33
- Location: Cape Town
Re: code to automate
I too ran it a few times without error earlier, so instead of commenting I thought I'd wait for Hans to verify...
Regards,
Rudi
If your absence does not affect them, your presence didn't matter.
Rudi
If your absence does not affect them, your presence didn't matter.
-
- 3StarLounger
- Posts: 315
- Joined: 04 May 2010, 15:18
Re: code to automate
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
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
-
- 3StarLounger
- Posts: 315
- Joined: 04 May 2010, 15:18
Re: code to automate
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.
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.
-
- Administrator
- Posts: 78540
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
-
- 3StarLounger
- Posts: 315
- Joined: 04 May 2010, 15:18
Re: code to automate
Thanks Hans
Here is one that I just run...
Here is one that I just run...
You do not have the required permissions to view the files attached to this post.
-
- Administrator
- Posts: 78540
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: code to automate
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
Best wishes,
Hans
Hans
-
- 3StarLounger
- Posts: 315
- Joined: 04 May 2010, 15:18
Re: code to automate
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.
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.
You do not have the required permissions to view the files attached to this post.
-
- Administrator
- Posts: 78540
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: code to automate
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
Best wishes,
Hans
Hans
-
- 3StarLounger
- Posts: 315
- Joined: 04 May 2010, 15:18
Re: code to automate
Fnatatsic Hans
thank you
thank you