VBA code to conditionally copy the dataSolved/Closed

Question

Hello,  

need help! 
see I need a vba code that can copy data from sheet1(raw data) to sheet 2,sheet3 and so on is certain condition matches..example RAW data is on sheet1, 

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 

need a macro that can automatically put data in sheet2 if place=AB that is complete raw,put data i.e complete raw in sheet3 if place=CD and so on ..and that is along with the Title. 

help me to find the solution..  


Configuration: Windows XP / Safari 535.2

RWomanizer · Accepted Answer

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

sunny2u86 · Answer

is any one who can help me..pls.

sunny2u86 · Answer

hi please use the  this link to get the raw file "  http://speedy.sh/RJs2g/pending-raw.xls  "


he data it contain is different then I asked but the logic is same.I need all the data in sheet1 will be copied to the sheet2,sheet3 and so on according to the "Group" in sheet1.. 
the sheet attached is without macro. 

thank you 
sunny.

TrowaD · Answer

Hi Sunny,

Is it possible to name each sheet after the group they are in?

So don't name your sheet: "FO CAL" but "Field Ops - Calgary".

Or keep the sheet name "FO CAL" and change the groupname accordingly.

Make a sheet for every groupname.

Post your results.

Best regards,
Trowa

sunny2u86 · Answer

HI Trowa,


yes you can change the name  of the sheet according to the group they are in say
"Field Ops - Calgary"..  
  
Please let me know if you need any other details.

Thank You,
Sunny

TrowaD · Answer

Good one Sunny,
I meant for you to change the sheet names.

But since I had some spare time (and I am a kind person) I did it for you.

Here is the code:
Sub MoveData()
Dim lRow As Integer

lRow = Range("A" & Rows.Count).End(xlUp).Row

Sheets("raw").Activate

For Each cell In Range("F2:F" & lRow)
cell.EntireRow.Copy
Sheets(cell.Value).Activate
Range("B" & Rows.Count).End(xlUp).Offset(1, -1).PasteSpecial
Next cell
Application.CutCopyMode = False
End Sub
And here is your file with code:
http://speedy.sh/acm4R/Sunny-pending-raw.xls

Best regards,
Trowa

sunny2u86 · Answer

Hi Trowa,

Great work again from you man! 
I really appreciate your work,but one question,since this raw data is changeable  and  new group is added as required so can you tell me how can it change it according to the requirement..

thank you
Sunny

TrowaD · Answer

Hi Sunny,

Good to see you like it :).

The adjusted code will check if a sheet already exists with the groups name. If not, a sheets is created with the missing groups name along with the format (first row header and column width of the first 6 columns.).

Here is the code:
Sub MoveData()
Dim lRow As Integer

lRow = Range("A" & Rows.Count).End(xlUp).Row

Sheets("raw").Activate

For Each cell In Range("F2:F" & lRow)

If Not SheetExists(cell.Value) Then
Sheets.Add
ActiveSheet.Name = cell.Value
Sheets("raw").Range("A1:F1").Copy
Sheets(cell.Value).Range("A1").PasteSpecial Paste:=xlPasteAll
Sheets(cell.Value).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths

End If

cell.EntireRow.Copy
Sheets(cell.Value).Activate
Range("B" & Rows.Count).End(xlUp).Offset(1, -1).PasteSpecial

Next cell

Application.CutCopyMode = False
End Sub

Function SheetExists(SheetName As String) As Boolean
SheetExists = False
On Error GoTo NoSuchSheet

If Len(Sheets(SheetName).Name) > 0 Then
SheetExists = True
Exit Function
End If

NoSuchSheet:
End Function

And here is your file with code for your convenience:
http://speedy.sh/zvnTp/Sunny-pending-raw.xls

Kind regards,
Trowa

sunny2u86 · Answer

Hey man,

Thanks again for your help!


thank you,
Sunny..

VBA code to conditionally copy the data

9 replies

Subscribe To Our Newsletter!