MACRO - Editing the Layout of Data

[PS951]

Hi,

I have a list of data in a spread sheet that shows feedback from mentors on each apprentice they have in their placement. Each row in the list represents a specific student and a date period of when the feedback is observed.

The columns include: Student Name, ID, Placement, Assess Date From, Assess Date To, Comments, Strengths. Weaknesses e.t.c. Some of the columns have entries that are sentences and some are numbers as a score from 1 to 4 (scores are marked for attendance and other aspects).

What I would like to do is Filter the Rows by name so that I get all the feedback relating to that person, which I am able to do. I would then like to create a button that, when pressed, will copy the filtered entries and paste them to a new workbook, then rearrange some of the data a few rows down so that some of the columns start underneath. I have created a button with a macro that does this and it works well. However, as the list of data increases with more and more feedback, when it is re-arranged with the button there is no gap between fields that have been moved. I need to create something that ensures that there is a "break" in between the columns that are moved so that they do not overlap.

Sorry if I have not explained this too well but any ideas you have would be greatly appreciated.

[arlu1201]

It will be good if you attach a sample workbook with before and after sheets.

[PS951]

Example.xlsx

Attached is an example version of the spreadsheet, I can't put up the original copy due to sensitive company info e.t.c.

In the example, sheet 1 shows all the data in the spreadsheet. Sheet 2 shows how the data would like to be displayed when filtered for Peter Johnson.



Cheers.

[arlu1201]

Does the filtered data move to a new tab in the same workbook or each different name to a different workbook?

[PS951]

The filtered data currently moves to a new workbook using the button I have in place.

As the spread sheet will grow the newly arranged data will have problems. At the moment, the macro will move the "Comments" Column from column "P" into column "A" row "15". with more data in the spread sheet there may already be data in row 15 so I need a macro that will put it below the data as opposed to a pre-determined cell.

[arlu1201]

Ok...so where does the next name's data move? To another workbook? You mean 1 workbook per person?

[PS951]

That would be the plan yes. So that after the meeting to discuss the feedback the workbook would be sent to the appropriate person. and the meetings people have for their feedback re-occur so more feedback would be added on a regular basis.

[nilem]

Try this. Save the attached file to your hard drive. Books will be created in the same folder as the current file

Please Login or Register  to view this content.

[PS951]

That works well it's solved the problem I've been having with adding more data to the spreadsheet. But I'd prefer it if it didn't create a new work book for every single name. In the real spread sheet there will eventually be about 100 names and this wouldn't be practical. Is it possible to create it so that when I filter that name and press the button it creates a work book for that name only? as opposed to all the names?

You've been a great help thank you

[PS951]

That works well it's solved the problem I've been having with adding more data to the spreadsheet. But I'd prefer it if it didn't create a new work book for every single name. In the real spread sheet there will eventually be about 100 names and this wouldn't be practical. Is it possible to create it so that when I filter that name and press the button it creates a work book for that name only? as opposed to all the names?

You've been a great help thank you

[nilem]

Two variants (with auxiliary sheet or not)

[PS951]

I'm having a problem with the code, the document is saved as a 2007 excel workbook. I am using it on Excel 2010 and it is working fine. However, when I try it at work on excel 2003 the code fails.
the code is:

Sub rtyrty()
Dim j&, k&, n&, sCrit$
Application.ScreenUpdating = 0
If ActiveSheet.FilterMode = False Then MsgBox "Filtered data is not found", 64: Exit Sub
sCrit = Mid(ActiveSheet.AutoFilter.Filters(1).Criteria1, 2)
If MsgBox("Create a book " & sCrit, vbQuestion + vbYesNo) = vbNo Then Exit Sub
[a1].CurrentRegion.Copy tempSh.Cells(1, 1)
With tempSh.[a1].CurrentRegion.Columns(16).Resize(, 5)
j = .Rows.Count
For k = 1 To 5
n = k * (j + 1) + 1: .Columns(k).Copy tempSh.Cells(n, 1)
Next k
.Delete Shift:=xlToLeft
End With
With tempSh: .Name = sCrit: .Copy: .UsedRange.Clear: End With
On Error Resume Next
With ActiveWorkbook
.SaveAs Filename:=ThisWorkbook.Path & "\" & sCrit & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
.Close 0
End With
Application.ScreenUpdating = -1
End Sub

'Sub rtyrty()
'Dim j&, k&, n&, sCrit$
'Application.ScreenUpdating = 0
'If ActiveSheet.FilterMode = False Then MsgBox "Filtered data is not found", 64: Exit Sub
'sCrit = Mid(ActiveSheet.AutoFilter.Filters(1).Criteria1, 2)
'If MsgBox("Create a book " & sCrit, vbQuestion + vbYesNo) = vbNo Then Exit Sub
'On Error Resume Next
'
'[a1].CurrentRegion.Copy
'With Workbooks.Add
' With .Sheets(1)
' .Paste
' With .[a1].CurrentRegion.Columns(16).Resize(, 5)
' j = .Rows.Count
' For k = 1 To 5
' n = k * (j + 1) + 1: .Columns(k).Copy Cells(n, 1)
' Next k
' .Delete Shift:=xlToLeft
' End With
' End With
' .SaveAs Filename:=ThisWorkbook.Path & "\" & sCrit & ".xlsx", _
' FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
' .Close 0
'End With
'Application.ScreenUpdating = -1
'End Sub

When the button is clicked, an error message come up and "xlOpenXMLWorkbook" is highlighted, why is this happening?


Cheers,

[nilem]

Replace this line

Please Login or Register  to view this content.

by this line

Please Login or Register  to view this content.

PS Use code tags when you write code in your posts