Excel/VBA - A macro to split data

December 2016


Microsoft Excel is a Microsoft office software application, which features graphic tools, pivot tables, macro programming called visual basic for applications (VBA) and calculations. It has a widely applied worksheet for these platforms. Visual basics for applications programming aspects allow users to employ a variety of numerical methods and report the results to the worksheets. In the Excel application, macros are written using VBA code. For those who cannot write VBA code, Excel provides a feature called macro recorder, which records activities of the user and creates VBA code, which will be in the form of a macro. Macros help to split data to different worksheets and eliminate repetitive tasks.

Issue


Department | Name | Amount Spent | 


In my file, there's one column which specifies the different departments of a company, with the money spent by the people. I need to separate it, by department to different sheets and also add a subtotal at the end.

How to write a macro for this??
Manually is not OK because it often comes up with a huge data.

Solution


Suppose your main data is in the sheet called "main".

The sample data is like this from A1 down and to right in this sheet "main"

Department Name Amount Spent

a q 1       
s w 5       
d e 3       
a r 2       
d t 4 


Open sheets with department name in this case a,s,d
Now run this macro "test" (I have also added another macro for undoing for what you have done and to rerun the macro "test"). Run the macro on the sample workbook (sheets "main", "a","s","d"). If it is OK you can use these in your original file.

KEEP THE ORIGINAL FILE SAFELY SOMEWHERE FOR RETRIEVAL IF NECESSARY

Macro 1:

Sub test()      
Dim r As Range, r1 As Range, r2 As Range      
Dim c2 As Range      
Worksheets("main").Activate      
Set r = Range(Range("a1"), Range("A1").End(xlDown))      
Set r1 = Range("a1").End(xlDown).Offset(5, 0)      
r.AdvancedFilter action:=xlFilterCopy, copytorange:=r1, unique:=True      
Set r2 = Range(r1.Offset(1, 0), r1.End(xlDown))      
For Each c2 In r2      
r.CurrentRegion.AutoFilter field:=1, Criteria1:=c2.Value      
r.CurrentRegion.Cells.SpecialCells(xlCellTypeVisible).Copy      
Worksheets(c2.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial      
r.CurrentRegion.AutoFilter      
Next c2      
End Sub


Macro 2:

Sub undo()      
Dim j As Integer, k As Integer      
j = Worksheets.Count      
For k = 1 To j      
If Worksheets(k).Name <> "main" Then      
Worksheets(k).Cells.Clear      
End If      
Next k      

End Sub

Note that


Thanks to venkat1926 for this tip on the forum.

Related :

This document entitled « Excel/VBA - A macro to split data » from CCM (ccm.net) is made available under the Creative Commons license. You can copy, modify copies of this page, under the conditions stipulated by the license, as this note appears clearly.