Thanks a lot for all of you Mahesh, Rajan & Sam
Regards, Shrinivas ________________________________ From: excel-macros@googlegroups.com [mailto:excel-macros@googlegroups.com] On Behalf Of rajan verma Sent: Tuesday, October 04, 2011 9:22 PM To: excel-macros@googlegroups.com Subject: Re: $$Excel-Macros$$ Splitting of files Try this Code : Sub MakeSeperat() Dim rngCell As Range Dim rngHeading As Range Dim rngData As Range Dim strClientName As String Dim wksSheet As Worksheet Dim wbWorkbook As Workbook strClientName = Application.InputBox("Please enter the Client Name (Exact)", "Client Name") Set rngHeading = Range("HeadingRange") Set wbWorkbook = Workbooks.Add(1) For Each wksSheet In ThisWorkbook.Worksheets LastRow = wksSheet.Range("A" & wksSheet.Rows.Count).End(xlUp).Row Set rngData = wksSheet.Range("A1:A" & LastRow) wbWorkbook.Worksheets.Add after:=ActiveSheet ActiveSheet.Range("A1:D1").Value = rngHeading.Value For Each rngCell In rngData If Trim(UCase(rngCell.Value)) = Trim(UCase(strClientName)) Then rngCell.EntireRow.Copy ActiveSheet.Range("A" & WorksheetFunction.CountA(Range("A:A")) + 1) End If Next ActiveSheet.Name = wksSheet.Name Next wbWorkbook.SaveAs ThisWorkbook.Path & strClientName End Sub On Mon, Oct 3, 2011 at 11:56 PM, Mahesh parab <mahes...@gmail.com<mailto:mahes...@gmail.com>> wrote: Hi Shrinivas find attach workbook HTH Mahesh On Mon, Oct 3, 2011 at 9:06 PM, Sam Mathai Chacko <samde...@gmail.com<mailto:samde...@gmail.com>> wrote: Here's a clean and swift approach. Workbook also attached. Just select the Dump File at the prompt Option Explicit Sub Consolidator() 'Code compliation by Sam Mathai Chacko alias GoldenLance on discussexcel forum Dim wbk As Workbook Dim wks As Worksheet Dim objCol As New Collection Dim lngSheetsInNewBook As Long Dim lngCounter As Long Dim lngLoop As Long Dim strNewSourceFile As String Dim strSavePath As String Dim varDiv As Variant Dim varBon As Variant Dim varRight As Variant Dim sngTimer As Single On Error GoTo ErrH sngTimer = Timer strNewSourceFile = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , "Please select source file [DUMP]") If strNewSourceFile = "False" Then ' If vbNo = MsgBox("Would you like to create a dump file?", vbYesNo + vbQuestion, "Dump") Then Exit Sub ' Else ' lngSheetsInNewBook = Application.SheetsInNewWorkbook ' Application.SheetsInNewWorkbook = 3 ' Set wbk = Workbooks.Add ' Application.SheetsInNewWorkbook = lngSheetsInNewBook ' ' wbk.Sheets(1).Name = "Div" ' wbk.Sheets(2).Name = "bon" ' wbk.Sheets(3).Name = "right" ' ' wbk.Sheets(Array("Div", "bon", "right")).Select ' Selection.Cells(6, 1).Resize(1, 4).Value = _ ' Array("Client Name", "Client Account", "Product", "No.") ' Application.Goto wbk.Sheets(1).Cells(1) ' End If Else Application.ScreenUpdating = False Set wbk = Workbooks.Open(strNewSourceFile) End If strSavePath = wbk.Path For lngSheetsInNewBook = 1 To UBound(Array("Div", "bon", "right")) + 1 Set wks = wbk.Worksheets("" & Array("Div", "bon", "right")(lngSheetsInNewBook - 1) & "") Select Case lngSheetsInNewBook Case 1 varDiv = wks.UsedRange.Value For lngCounter = 2 To UBound(varDiv) If Len(Trim(varDiv(lngCounter, 1))) <> 0 Then On Error Resume Next objCol.Add varDiv(lngCounter, 1), CStr(varDiv(lngCounter, 1)) Err.Clear: On Error GoTo -1: On Error GoTo 0: On Error GoTo ErrH End If Next lngCounter Case 2 varBon = wks.UsedRange.Value For lngCounter = 2 To UBound(varBon) If Len(Trim(varBon(lngCounter, 1))) <> 0 Then On Error Resume Next objCol.Add varBon(lngCounter, 1), CStr(varBon(lngCounter, 1)) Err.Clear: On Error GoTo -1: On Error GoTo 0: On Error GoTo ErrH End If Next lngCounter Case 3 varRight = wks.UsedRange.Value For lngCounter = 2 To UBound(varRight) If Len(Trim(varRight(lngCounter, 1))) <> 0 Then On Error Resume Next objCol.Add varRight(lngCounter, 1), CStr(varRight(lngCounter, 1)) Err.Clear: On Error GoTo -1: On Error GoTo 0: On Error GoTo ErrH End If Next lngCounter End Select Next lngSheetsInNewBook wbk.Close 0 Set wbk = Nothing lngSheetsInNewBook = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = 3 For lngLoop = 1 To objCol.Count Set wbk = Workbooks.Add wbk.SaveAs strSavePath & "\" & objCol.Item(lngLoop), ThisWorkbook.FileFormat wbk.Sheets(1).Name = "Div" wbk.Sheets(2).Name = "bon" wbk.Sheets(3).Name = "right" For lngSheetsInNewBook = 1 To UBound(Array("Div", "bon", "right")) + 1 Set wks = wbk.Worksheets(Array("Div", "bon", "right")(lngSheetsInNewBook - 1)) wks.Cells(6, 1).Resize(1, 4).Value = _ Array("Client Name", "Client Account", "Product", "No.") Select Case lngSheetsInNewBook Case 1 Application.Goto wks.Cells(1) For lngCounter = 2 To UBound(varDiv) If varDiv(lngCounter, 1) = objCol.Item(lngLoop) Then wks.Cells(wks.Rows.Count, 1).End(xlUp)(2).Resize(1, 4).Value = Array(varDiv(lngCounter, 1), varDiv(lngCounter, 2), varDiv(lngCounter, 3), varDiv(lngCounter, 4)) End If Next lngCounter With wks.UsedRange.Borders .LineStyle = xlContinuous .Weight = xlThin .Parent.Rows(1).Font.Bold = True .Parent.EntireColumn.AutoFit End With Case 2 Application.Goto wks.Cells(1) For lngCounter = 2 To UBound(varBon) If varBon(lngCounter, 1) = objCol.Item(lngLoop) Then wks.Cells(wks.Rows.Count, 1).End(xlUp)(2).Resize(1, 4).Value = Array(varBon(lngCounter, 1), varBon(lngCounter, 2), varBon(lngCounter, 3), varBon(lngCounter, 4)) End If Next lngCounter With wks.UsedRange.Borders .LineStyle = xlContinuous .Weight = xlThin .Parent.Rows(1).Font.Bold = True .Parent.EntireColumn.AutoFit End With Case 3 Application.Goto wks.Cells(1) For lngCounter = 2 To UBound(varRight) If varRight(lngCounter, 1) = objCol.Item(lngLoop) Then wks.Cells(wks.Rows.Count, 1).End(xlUp)(2).Resize(1, 4).Value = Array(varRight(lngCounter, 1), varRight(lngCounter, 2), varRight(lngCounter, 3), varRight(lngCounter, 4)) End If Next lngCounter With wks.UsedRange.Borders .LineStyle = xlContinuous .Weight = xlThin .Parent.Rows(1).Font.Bold = True .Parent.EntireColumn.AutoFit End With End Select Next lngSheetsInNewBook Application.Goto wbk.Sheets(1).Cells(1) wbk.Close 1 Next lngLoop ErrH: Erase varDiv Erase varBon Erase varRight If Err.Number <> 0 Then MsgBox Err.Description, vbOKOnly + vbInformation, "Unknown Error" Err.Clear: On Error GoTo -1: On Error GoTo 0 Else MsgBox objCol.Count & " workbooks compiled in " & Timer - sngTimer & " seconds!", vbOKOnly + vbInformation, "Consolidator" End If Application.SheetsInNewWorkbook = lngSheetsInNewBook Application.ScreenUpdating = True Set wbk = Nothing Set wks = Nothing lngSheetsInNewBook = Empty strNewSourceFile = vbNullString Set objCol = Nothing lngCounter = Empty lngLoop = Empty End Sub On Mon, Oct 3, 2011 at 1:59 PM, Chidurala, Shrinivas <shrinivas.chidur...@citi.com<mailto:shrinivas.chidur...@citi.com>> wrote: Thanks Mahesh, But it is capturing only div sheet, i want to capture all 3 sheets. Regards, Shrinivas ________________________________ From: Mahesh parab [mailto:mahes...@gmail.com<mailto:mahes...@gmail.com>] Sent: Saturday, October 01, 2011 10:38 PM To: excel-macros@googlegroups.com<mailto:excel-macros@googlegroups.com>; Chidurala, Shrinivas [ICG-GTS] Subject: Re: $$Excel-Macros$$ Splitting of files Hi Shrinivas Try : Sub Mtest() Dim Rng As Range Dim ws As Worksheet Dim shname As String Dim i As Integer Dim shn As Long Dim mx As Variant Dim x As Integer Dim LR As Long Dim sPath As String, sFileName As String On Error Resume Next Application.DisplayAlerts = False Sheets("Temp").Delete Application.DisplayAlerts = True Set Rng = Sheets("Div").Range("A6:A" & Cells(Rows.Count, 1).End(xlUp).Row) Set ws2 = Worksheets.Add(After:=Sheets(Sheets.Count)) With ws2 Rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("A1"), unique:=True .Name = "Temp" End With Sheets("Temp").Columns("A").SpecialCells(xlCellTypeBlanks).Delete shift:=xlShiftUp LR = Sheets("Temp").Cells(Rows.Count, "A").End(xlUp).Row For i = 2 To LR Cname = Sheets("Temp").Cells(i, 1) Set ws2 = Workbooks.Add mx = Array("Div", "bon", "right") shn = 1 - LBound(mx) For x = LBound(mx) To UBound(mx) Sheets(x + shn).Name = mx(x) Next x m = ws2.Name ThisWorkbook.Activate For Each ws In ThisWorkbook.Worksheets If ws.Name <> "Temp" Then ws.UsedRange.AutoFilter Field:=1, Criteria1:=Cname ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy shname = ws.Name Application.Goto _ Workbooks(m).Sheets(shname).Cells(1, 1) ActiveSheet.Paste ThisWorkbook.Activate End If Next ws ws2.Activate 'Save the new workbook sPath = ThisWorkbook.Path & "\" 'sPath = "C:\Users\MAHESH\Downloads\Delete\" sFileName = Cname & ".xls" Application.DisplayAlerts = False ws2.SaveAs (sPath & sFileName) ws2.Close True ThisWorkbook.Activate Next i End Sub HTH Mahesh On Sat, Oct 1, 2011 at 4:34 PM, Chidurala, Shrinivas <shrinivas.chidur...@citi.com<mailto:shrinivas.chidur...@citi.com>> wrote: Dear All, I have dump file of 3 sheets which contain the data of some clients in each sheet, I want to split the files into client wise and also note the client name is all sheet is in column A. Please advise me to create macro. Find attached sample of dump file and client file for your reference. Regards, Shrinivas -- ---------------------------------------------------------------------------------- Some important links for excel users: 1. Follow us on TWITTER for tips tricks and links : http://twitter.com/exceldailytip 2. Join our LinkedIN group @ http://www.linkedin.com/groups?gid=1871310 3. Excel tutorials at http://www.excel-macros.blogspot.com<http://www.excel-macros.blogspot.com/> 4. Learn VBA Macros at http://www.quickvba.blogspot.com<http://www.quickvba.blogspot.com/> 5. Excel Tips and Tricks at http://exceldailytip.blogspot.com<http://exceldailytip.blogspot.com/> To post to this group, send email to excel-macros@googlegroups.com<mailto:excel-macros@googlegroups.com> <><><><><><><><><><><><><><><><><><><><><><> Like our page on facebook , Just follow below link http://www.facebook.com/discussexcel -- ---------------------------------------------------------------------------------- Some important links for excel users: 1. Follow us on TWITTER for tips tricks and links : http://twitter.com/exceldailytip 2. Join our LinkedIN group @ http://www.linkedin.com/groups?gid=1871310 3. Excel tutorials at http://www.excel-macros.blogspot.com<http://www.excel-macros.blogspot.com/> 4. Learn VBA Macros at http://www.quickvba.blogspot.com<http://www.quickvba.blogspot.com/> 5. Excel Tips and Tricks at http://exceldailytip.blogspot.com<http://exceldailytip.blogspot.com/> To post to this group, send email to excel-macros@googlegroups.com<mailto:excel-macros@googlegroups.com> <><><><><><><><><><><><><><><><><><><><><><> Like our page on facebook , Just follow below link http://www.facebook.com/discussexcel -- Sam Mathai Chacko -- ---------------------------------------------------------------------------------- Some important links for excel users: 1. Follow us on TWITTER for tips tricks and links : http://twitter.com/exceldailytip 2. Join our LinkedIN group @ http://www.linkedin.com/groups?gid=1871310 3. Excel tutorials at http://www.excel-macros.blogspot.com<http://www.excel-macros.blogspot.com/> 4. Learn VBA Macros at http://www.quickvba.blogspot.com<http://www.quickvba.blogspot.com/> 5. Excel Tips and Tricks at http://exceldailytip.blogspot.com<http://exceldailytip.blogspot.com/> To post to this group, send email to excel-macros@googlegroups.com<mailto:excel-macros@googlegroups.com> <><><><><><><><><><><><><><><><><><><><><><> Like our page on facebook , Just follow below link http://www.facebook.com/discussexcel -- ---------------------------------------------------------------------------------- Some important links for excel users: 1. Follow us on TWITTER for tips tricks and links : http://twitter.com/exceldailytip 2. Join our LinkedIN group @ http://www.linkedin.com/groups?gid=1871310 3. Excel tutorials at http://www.excel-macros.blogspot.com<http://www.excel-macros.blogspot.com/> 4. Learn VBA Macros at http://www.quickvba.blogspot.com<http://www.quickvba.blogspot.com/> 5. Excel Tips and Tricks at http://exceldailytip.blogspot.com<http://exceldailytip.blogspot.com/> To post to this group, send email to excel-macros@googlegroups.com<mailto:excel-macros@googlegroups.com> <><><><><><><><><><><><><><><><><><><><><><> Like our page on facebook , Just follow below link http://www.facebook.com/discussexcel -- Regards Rajan verma +91 9158998701 -- ---------------------------------------------------------------------------------- Some important links for excel users: 1. Follow us on TWITTER for tips tricks and links : http://twitter.com/exceldailytip 2. Join our LinkedIN group @ http://www.linkedin.com/groups?gid=1871310 3. Excel tutorials at http://www.excel-macros.blogspot.com 4. Learn VBA Macros at http://www.quickvba.blogspot.com 5. Excel Tips and Tricks at http://exceldailytip.blogspot.com To post to this group, send email to excel-macros@googlegroups.com <><><><><><><><><><><><><><><><><><><><><><> Like our page on facebook , Just follow below link http://www.facebook.com/discussexcel -- ---------------------------------------------------------------------------------- Some important links for excel users: 1. Follow us on TWITTER for tips tricks and links : http://twitter.com/exceldailytip 2. Join our LinkedIN group @ http://www.linkedin.com/groups?gid=1871310 3. Excel tutorials at http://www.excel-macros.blogspot.com 4. Learn VBA Macros at http://www.quickvba.blogspot.com 5. Excel Tips and Tricks at http://exceldailytip.blogspot.com To post to this group, send email to excel-macros@googlegroups.com <><><><><><><><><><><><><><><><><><><><><><> Like our page on facebook , Just follow below link http://www.facebook.com/discussexcel
