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
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