Wednesday, December 25, 2013

Split data of a Single workbook into different workbook

Option Explicit
Dim wb As Workbook, ws As Worksheet, myrng As Range, i As Integer, x As Integer
Dim fso As Object, fldr As Object, fl As Object, item_, itemcol As Collection
Dim path As String, rawdata
Sub migrateData()
Application.ScreenUpdating = False
On Error Resume Next
path = "D:\Somu\Task12092013-3"
 Set fso = New Scripting.FileSystemObject
 Set fldr = fso.GetFolder(path)
 Set itemcol = New Collection
 'For Each fl In fldr.Files
 Set wb = ThisWorkbook
 Set ws = wb.ActiveSheet
 MsgBox ws.UsedRange.Address
 Set myrng = ws.Range(ws.UsedRange.Address)
 item_ = ws.Range("d2:" & ws.Range("d2").End(xlDown).Address).Value
  For i = 1 To UBound(item_, 1)
        itemcol.Add item_(i, 1), item_(i, 1)

  Next
  For x = 1 To itemcol.Count
    myrng.AutoFilter , field:=4, Criteria1:=itemcol(x)
    rawdata = ws.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible)
        For Each fl In fldr.Files
               If Left(fl.Name, InStr(1, fl.Name, ".") - 1) = itemcol(x) Then
                Workbooks.Open path & "\" & fl.Name
                ActiveWorkbook.ActiveSheet.Range("a" & ActiveSheet.UsedRange.Rows.Count).Resize(UBound(rawdata, 1), UBound(rawdata, 2)) = rawdata
                ActiveWorkbook.Save
                ActiveWorkbook.Close
               Else
                    Workbooks.Add
                    ActiveWorkbook.ActiveSheet.Range("a1") = "City"
                    ActiveWorkbook.ActiveSheet.Range("b1") = "Map Code"
                    ActiveWorkbook.ActiveSheet.Range("c1") = "Model"
                    ActiveWorkbook.ActiveSheet.Range("d1") = "Country"
                    ActiveWorkbook.ActiveSheet.Range("e1") = "Batch Refference"
                    ActiveWorkbook.ActiveSheet.Range("f1") = "Source"
                    ActiveWorkbook.ActiveSheet.Range("a2").Resize(UBound(rawdata, 1), UBound(rawdata, 2)) = rawdata
                    ActiveWorkbook.SaveAs path & "\" & itemcol(x), FileFormat:=56
                    ActiveWorkbook.Close
                    Exit For
               End If
 
        Next
  Next
End Sub


For file:
https://drive.google.com/file/d/0B23eJ2xd9ODydUtzYkwtaU5ZMDA/edit?usp=sharing

No comments:

Post a Comment