Excel/VBA - A macro to split data

Ask a question

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.


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.


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.


Macro 1:

Sub test()      
Dim r As Range, r1 As Range, r2 As Range      
Dim c2 As Range      
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      
Worksheets(c2.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial      
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      
End If      
Next k      

End Sub

Note that

Thanks to venkat1926 for this tip on the forum.
Jean-François Pillou

CCM is a leading international tech website. Our content is written in collaboration with IT experts, under the direction of Jeff Pillou, founder of CCM.net. CCM reaches more than 50 million unique visitors per month and is available in 11 languages.

Learn more about the CCM team