Hi
Attached is the Text File
Thanks and Regards,
Vivek Agrawal
Skype ID - vivek.agrawal83
GoogleMoonlight.com - Saving energy-Save Earth
On Fri, Aug 7, 2009 at 5:34 PM, Upendra Singh
<upendrasinghsen...@gmail.com>wrote:
> Hi Vivek,
>
>
>
>
>
> Send me the macro as text file as my outlook had blocked “Potential unsafe
> attachment .bas” please.
>
>
>
> Regards,
>
>
>
> Upendra Singh
>
> +91-9910227325, +91-9310760597
>
>
>
>
> -------------------------------------------------------------------------------------------------------------
>
> There are 10 kinds of people: Those who understand binary and those who
> don’t.
>
>
> -------------------------------------------------------------------------------------------------------------
>
>
>
> *From:* excel-macros@googlegroups.com [mailto:
> excel-mac...@googlegroups.com] *On Behalf Of *vivek agrawal
> *Sent:* Friday, August 07, 2009 11:24 AM
> *To:* excel-macros@googlegroups.com
> *Subject:* $$Excel-Macros$$ Re: Split data to different Sheet ***
> URGENT***
>
>
>
> Hi Shrinivas
>
>
>
> Please Find Attached the required Module. Import this module in your
> workbook using the VBE.
>
>
>
> You just need to open that master sheet and run the Sub Procudure "COPY
> UNIQUE".
>
>
>
> The module will do the rest of the task. it would create separate sheets
> based on client and then save these different sheets in the same location
> where the file containing this module is present. you can modify the code
> based on your needs.
>
>
>
> Feel free to mail me if more help required.
>
>
>
> Thanks and Regards,
> Vivek Agrawal
> Skype ID - vivek.agrawal83
>
> GoogleMoonlight.com - Saving energy-Save Earth
>
>
> On Fri, Aug 7, 2009 at 10:34 AM, Chidurala, Shrinivas <
> shrinivas.chidur...@citi.com> wrote:
>
> 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
>
>
>
>
> >
>
>
--~--~---------~--~----~------------~-------~--~----~
----------------------------------------------------------------------------------
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
-~----------~----~----~----~------~----~------~--~---
Sub CopyUnique()
Range("A1").Select
Range(Selection, Selection.End(xlDown)).AdvancedFilter
Action:=xlFilterInPlace, Unique:=True
ActiveWindow.ScrollRow = 1
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
ActiveSheet.Name = "temp"
Sheets(1).Select
Application.CutCopyMode = False
Range("A1").Select
ActiveSheet.ShowAllData
Selection.AutoFilter
'Range("A2").Select
'Columns("A:A").ColumnWidth = 24.43
'Range("A1").Select
Sheets("temp").Select
' Application.CutCopyMode = False
Range("A1").Select
Call create_worksheets_based_on_list
Sheets("temp").Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Sheets(1).Select
' Application.CutCopyMode = False
Range("A2").Select
Call Transfer
Sheets(1).Select
' Application.CutCopyMode = False
Range("A2").Select
'Sheets(1).Range("a2").Select
Call ApplyFormatting
Call SaveAllWS
End Sub
Sub SaveAllWS()
Dim ws As Worksheet
sheetscount = ActiveWorkbook.Sheets.Count
For x = 1 To sheetscount
Set ws = Sheets(x)
ws.Copy
With ws.UsedRange
.Value = .Value
End With
Set wb = ActiveWorkbook
' CurDir = CurDir()
file = ThisWorkbook.FullName 'this returns eg. c:\abc\abc.xls
Filename = ThisWorkbook.Name ' this returns eg. abc.xls
Position = InStr(1, file, Filename, 1) 'this returns eg. 8
Position = Position - 2 'this is to doc the "\a"
file = Left(file, Position) 'this returns eg. C:\abc
wb.SaveAs file & "\" & ws.Name & ".xls", FileFormat:=56
' wb.SaveAs "E:\vivek\project 21st may 2009\june, 2009\29th\new files\" &
ws.Name & ".xls"
wb.Close True
Next x
End Sub
Sub create_worksheets_based_on_list()
'
' create_worksheets_based_on_list Macro
'
' Keyboard Shortcut: Ctrl+m
'
'Dim var As String
' Dim CreateRange As Range
'
' For x = 1 To 20
'var = Selection.Value
' Sheets.Add
' ActiveSheet.Name = var
' ActiveSheet.Next.Select
' Application.CutCopyMode = False
'ActiveCell.Offset(1, 0).Select
' Next x
Dim SheetName As String
Dim CreateRange As Range
Dim CreateWorkbook As Workbook
Dim CreateSheet As Worksheet
Set CreateWorkbook = ActiveWorkbook
For Each rngData In Range(Selection, Selection.End(xlDown))
SheetName = Selection.Value
Sheets.Add
ActiveSheet.Name = Trim(SheetName)
Set CreateSheet = ActiveSheet
CreateWorkbook.Sheets(1).Range("a1").EntireRow.Copy
CreateSheet.Range("A" _
& CreateSheet.Range("A" & CreateSheet.Rows.Count).End(xlUp).Row)
'set wrap for all the cells
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
With Selection
.WrapText = True
End With
Range("A2").Select
' Range(Selection, Selection.End(xlToRight)).Select
' Range(Selection, Selection.End(xlDown)).Select
' Selection.EntireRow.AutoFit
' Selection.EntireColumn.AutoFit
'Range("A2").Select
ActiveSheet.Next.Select
Application.CutCopyMode = False
ActiveCell.Offset(1, 0).Select
Next
End Sub
Sub Transfer()
Dim shtTemp As Worksheet
Dim lngOutRow As Long
Dim rngData As Range
For Each rngData In Range(Sheets(1).Range("a2"),
Sheets(1).Range("a2").End(xlDown))
Set shtTemp = GetWorksheet(Trim(rngData.Value))
'If Not shtTemp Is Nothing Then
'copy row across the sheet appending to end
rngData.EntireRow.Copy shtTemp.Range("A" & shtTemp.Range("A" _
& shtTemp.Rows.Count).End(xlUp).Offset(1, 0).Row)
' Else
' MsgBox "Sheet for " & rngData.Value & " does not exists",
vbExclamation
' End If
Next
End Sub
Function GetWorksheet(Name As String) As Worksheet
' return reference to worksheet if it exists
On Error Resume Next
Set GetWorksheet = Worksheets(Name)
Exit Function
End Function
Sub ApplyFormatting()
Dim ws As Worksheet
sheetscount = ActiveWorkbook.Sheets.Count
Sheets(1).Select
Cells.Select
Selection.Copy
For x = 2 To sheetscount
Sheets(x).Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Next x
Application.CutCopyMode = False
For y = 2 To sheetscount
Sheets(y).Select
Range("A1").Select
'' Range(Selection, Selection.End(xlDown)).Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
''Rows("4:4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete Shift:=xlUp
Range("A1").Select
''Range(Selection, Selection.End(xlToRight)).Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 1).Select
''Columns("D:D").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.EntireColumn.Delete Shift:=xlToLeft
ActiveWindow.ScrollColumn = 1
Range("A1").Select
'Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Range("A1").Select
Next y
'Call ApplyFormatting
End Sub
