Hi,
Try the below code it will work
---------------------------------------------------------------
Sub splitdata()
' Macro Cracked by SJ
Dim rnge As Range, subrnge As Range
Dim strdata(), shtname() As String
Dim i As Integer, r As Integer, s As Integer, ir As Integer
Dim currentshtname As String, currentfilename As String
Application.DisplayAlerts = False
Application.StatusBar = "Split Data Macro working"
On Error GoTo errorhandler1
Set rnge = Application.InputBox(prompt:="Select the Data Range you want to
Split?" + vbCrLf + "Note: Ensure you select Column Heading Too." + vbCrLf +
vbCrLf + "-->Cracked by Sathish Jalendran", Title:="Split Data",
Default:="A1", Type:=8)
'for selecting the criteria range
Set subrnge = Application.InputBox(prompt:="Select the Column/Sub Data Range
based on which the Data will split?" + vbCrLf + "Note: Ensure you select
Column Heading Too and Ensure there are no blank cells in the range given.",
Title:="Split Data", Default:="A1", Type:=8)
On Error GoTo errorhandler1
s = Application.InputBox(prompt:="Select the Category" + vbCrLf _
+ "1-->Split the data by Sheets" + vbCrLf _
+ "2-->Split the data by Workbooks", Title:="Split Data", Default:=1,
Type:=1)
If s = 0 Then
GoTo errorhandler1
End If
'If s = 1 Then
ir = MsgBox("Do you want rename the New worksheets based on the criteria
Data", vbYesNo, "Split Data")
currentshtname = ActiveSheet.Name
'Else
' ir = vbYes
currentfilename = ActiveWorkbook.Name
'End If
Application.ScreenUpdating = False
'for indentifying the unique values in subrange
subrnge.Copy
Workbooks.Add
ActiveSheet.Paste
Range("A1", ActiveCell.End(xlDown)).AdvancedFilter Action:=xlFilterInPlace,
Unique:=True
Selection.Copy
ActiveSheet.Next.Select
ActiveSheet.Paste
Range("A2").Select
Range(ActiveCell, ActiveCell.End(xlDown)).Select
r = Selection.Count
ReDim strdata(r)
i = 0
For Each cell In Selection
strdata(i) = cell.Value
i = i + 1
Next cell
If ir = vbYes Then
Selection.Replace What:="\", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="/", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="[", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="]", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:=":", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
i = 0
ReDim shtname(Selection.Count)
For Each cell In Selection
On Error Resume Next
cell.Value = Application.WorksheetFunction.Substitute(cell.Value, "*", "")
cell.Value = Application.WorksheetFunction.Substitute(cell.Value, "?", "")
cell.Value = Left(cell.Value, 30)
shtname(i) = cell.Value
i = i + 1
Next cell
End If
ActiveWorkbook.Close savechanges:=False
subrnge.Select
For r = 0 To r - 1
Selection.AutoFilter Field:=1, Criteria1:=strdata(r)
If rnge.Range("A1").Address <> Range("A1").Address Then
Range(ActiveCell.EntireColumn, ActiveCell.EntireRow).Select
Else
rnge.Range("A1").Select
Range(ActiveCell.End(xlToRight), ActiveCell.End(xlDown)).Select
End If
Selection.Copy
If s = 1 Then
Worksheets.Add After:=Sheets(Sheets.Count)
ElseIf s = 2 Then
Workbooks.Add
End If
ActiveSheet.Paste
If ir = vbYes Then
ActiveSheet.Name = shtname(r)
'ActiveSheet.Name = strdata(r)
End If
Range("A1").Select
Columns.EntireColumn.AutoFit
If s = 1 Then
Sheets(currentshtname).Select
ElseIf s = 2 Then
Workbooks(currentfilename).Activate
End If
Next r
Selection.AutoFilter
rnge.Range("A1").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.StatusBar = False
Exit Sub
errorhandler1:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.StatusBar = False
MsgBox ("Error:= Error Occured, Program now Exits")
End Sub
------------------------------------------------------------------------
Regards
Sathish Jalendran
-----Original Message-----
From: excel-macros@googlegroups.com [mailto:excel-mac...@googlegroups.com]
On Behalf Of Chidurala, Shrinivas
Sent: 07 August 2009 AM 10:35
To: MS EXCEL AND VBA MACROS
Subject: $$Excel-Macros$$ Split data to different Sheet *** URGENT***
Dear Friends,
Find attached a dump file of all clients,
1. I want one macro to spit the date as per clients in different sheet of
same Excel and the same name should be the client name.
2. I want another macro to split data as per client in new excel and save in
C:\.
Regards,
Shrinivas
The information contained in this electronic message and any attachments to
this message are intended for the exclusive
use of the addressee(s) and may contain proprietary, confidential or privileged
information. If you are not the intended
recipient, you should not disseminate, distribute or copy this e-mail. Please
notify the sender immediately and destroy
all copies of this message and any attachments contained in it.
--~--~---------~--~----~------------~-------~--~----~
----------------------------------------------------------------------------------
Some important links for excel users:
1. Excel and VBA Tutorials(Video and Text), Free add-ins downloads at
http://www.excelitems.com
2. Excel tutorials at http://www.excel-macros.blogspot.com
3. Learn VBA Macros at http://www.vbamacros.blogspot.com
4. Excel Tips and Tricks at http://exceldailytip.blogspot.com
To post to this group, send email to excel-macros@googlegroups.com
If you find any spam message in the group, please send an email to:
Ayush Jain @ jainayus...@gmail.com or
Ashish Jain @ 26may.1...@gmail.com
<><><><><><><><><><><><><><><><><><><><><><>
HELP US GROW !!
We reach over 5,200 subscribers worldwide and receive many nice notes about the
learning and support from the group. Our goal is to have 10,000 subscribers by
the end of 2009. Let friends and co-workers know they can subscribe to group at
http://groups.google.com/group/excel-macros/subscribe
-~----------~----~----~----~------~----~------~--~---
