A VBA code to conditionally copy data from one sheet to another

Ask a question


Issue


I need a VBA code that can copy data from sheet1(raw data) to sheet 2,sheet3 and so on...based on a certain condition matches.
column---A------------B------------C------------D-------E
-----------name-----place----company---country
-----------name1----AB-------Nokia-------USA
-----------name2----CD-------Sony--------UK
-----------name3-----EF-------LG-----------INDIA
-----------name4-----AB------Sony------RUSSIA
-----------name5-----AB------Sony------GERMANY
-----------name6-----CD------Nokia------INDIA
-----------name7-----CD------Ericsson--USA
-----------name8-----EF------Ericsson----RUSSIA
-----------name9-----GH------Lenore-----UK
-----------name10---GH-------HP---------INDIA

Solution


You can use following codes

Sub SplitSheets() 
Dim DataSht, wsCrit, SplitSht As Worksheet 
Dim lrUnq, lrData, i As Long 
Dim FtrVal As String 

Application.ScreenUpdating = False 
Set DataSht = Worksheets("sheet1") 'change it to the name of your raw data sheet 
lrData = DataSht.Range("a" & Rows.Count).End(xlUp).Row 
Set wsCrit = Worksheets.Add 
DataSht.Range("B1:l" & lrData).AdvancedFilter Action:=xlFilterCopy, _ 
CopyToRange:=wsCrit.Range("A1"), Unique:=True 
lrUnq = wsCrit.Range("a" & Rows.Count).End(xlUp).Row 
For i = 2 To lrUnq 
FtrVal = wsCrit.Range("A" & i).Value 
Set SplitSht = Worksheets.Add 
DataSht.Select 
'DataSht.ShowAllData 
ActiveSheet.AutoFilterMode = False 
ActiveSheet.Range("A1:Z" & lrData).AutoFilter Field:=2, Criteria1:=FtrVal 
Range("a1").Select 
Range(Selection, Selection.End(xlToRight)).Select 
Range(Selection, Selection.End(xlDown)).Select 
Selection.Copy 
SplitSht.Select 
Range("A1").Select 
ActiveSheet.Paste 
'Cells.Select 
Cells.EntireColumn.AutoFit 
SplitSht.Name = FtrVal 
Application.CutCopyMode = False 
Next i 
Application.DisplayAlerts = False 
wsCrit.Delete 
Application.DisplayAlerts = True 
.AutoFilterMode = False 
End Sub


Thanks to RWomanizerfor this tip.
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