Microsoft Excel - how to split .xlsb file

Asked By vmp on 13-Apr-11 06:07 AM
Hello everyone...
 
i have one large .xlsb file. in that Column A having Distict name.

Now i want to split that data in different sheets with district name wise.

is there any solution for that.

Vmp
Jitendra Faye replied to vmp on 13-Apr-11 06:49 AM
For split .xlsb file use following code-

Sub Macro1()
Dim rLastCell As Range
Dim rCells As Range
Dim strName As String
Dim lLoop As Long, lCopy As Long
Dim wbNew As Workbook

    With ThisWorkbook.Sheets(1)
    Set rLastCell = .Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious)
    
        For lLoop = 1 To rLastCell.Row Step 500
        lCopy = lCopy + 1
            Set wbNew = Workbooks.Add
                .Range(.Cells(lLoop, 1), .Cells(lLoop + 500, .Columns.Count)).EntireRow.Copy _
                    Destination:=wbNew.Sheets(1).Range("A1")
            wbNew.Close SaveChanges:=True, Filename:="Chunk" & lCopy & "Rows" & lLoop & "-" & lLoop + 500
        Next lLoop
    End With


End Sub


For more detail follow this link.

http://www.ozgrid.com/forum/showthread.php?t=82788

I hope this will help you.
Jackpot . replied to vmp on 16-Apr-11 08:46 AM
Hi

Try the below macro which would split the data to multiple sheets based on col A value..The sheets will be named after the value in ColA.


Sub SplitDatatoSheets()
Dim wsTarget As Worksheet, wsSource As Worksheet
Dim lngRow As Long, lngNewRow As Long
  
Set wsSource = ActiveSheet
For lngRow = 2 To wsSource.Cells(Rows.Count, "A").End(xlUp).Row
  If Not SheetExists(CStr(wsSource.Range("A" & lngRow))) Then
  Set wsTarget = Worksheets.Add(After:=Sheets(Sheets.Count))
  wsTarget.Name = CStr(wsSource.Range("A" & lngRow))
  Else
  Set wsTarget = Sheets(CStr(wsSource.Range("A" & lngRow)))
  End If
    
  lngNewRow = wsTarget.Cells(Rows.Count, "A").End(xlUp).Row + 1
  wsSource.Rows(lngRow).Copy wsTarget.Range("A" & lngNewRow)
Next
wsSource.Activate
  
End Sub
  
Function SheetExists(strSheetName) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(strSheetName)
If Not ws Is Nothing Then SheetExists = True
End Function