Copy Specific Cells from files under Folder/SubFolder

Option Explicit
Dim objFso As Object, objFolder As Object, pathname As String, eachfile As Variant, objFolder1 As Object, eachfolder As Object
Dim tempcounter As Long, wb As Workbook, i As Integer, j As Integer


Sub copyFromSpecificfolderandsubfolder()
On Error Resume Next
pathname = "D:\Somu\ExcelClasses Notes"
Set objFso = New Scripting.FileSystemObject
Set objFolder = objFso.GetFolder(pathname)
Set objFolder1 = objFolder.SubFolders
Set wb = ThisWorkbook
tempcounter = 1
Call readfile(objFolder, tempcounter)

For Each eachfolder In objFolder1

Call readfile(eachfolder, tempcounter)

Next
tempcounter = 0
End Sub

Sub readfile(myFolder As Scripting.Folder, tempcounter)

For Each eachfile In myFolder.Files
    If checkExtension(eachfile) = True Then
        tempcounter = tempcounter + 1
 
        Workbooks.Open eachfile
        ActiveWorkbook.Sheets(1).Range("A2:C2").Copy wb.Sheets(1).Range("A" & tempcounter)
        ActiveWorkbook.Close
    End If
Next
End Sub

Public Function checkExtension(eachfile) As Boolean
i = InStr(1, eachfile, ".")
j = Len(eachfile)

Select Case Mid(eachfile, i + 1, (j - i))
    Case "xls"
        checkExtension = True
    Case "Xlsm"
        checkExtension = True
    Case "xlsx"
        checkExtension = True
    Case "xlsb"
        checkExtension = True
    Case Else
        checkExtension = False
End Select
End Function

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

A Simple VBA Code for Creating PivotTable

Dim pttbl As PivotTable
Sub createPivot()
On Error Resume Next
For Each pttbl In ThisWorkbook.Sheets(2).PivotTables
        ThisWorkbook.Sheets(2).Range(pttbl.TableRange2.Address).Delete
Next

   ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=ThisWorkbook.Sheets(1).Range("A1").CurrentRegion.Address). _
   CreatePivotTable TableDestination:=ThisWorkbook.Sheets(2).Range("C5"), TableName:="PivotTable1"
    With ThisWorkbook.Sheets(2).PivotTables("PivotTable1")
        .PivotFields("Processed by").Orientation = xlRowField
        .PivotFields("status").Orientation = xlDataField
        .PivotFields("Transaction type").Orientation = xlPageField
     
    End With

End Sub




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

Sending Attachment through OutLook

Sub sendMail
Dim outApp As New Outlook.Application, outMail As Variant,mailId as String
Set outMail = outApp.CreateItem(olMailItem)
        With outMail
            .To = mailId
            .Subject = Mid(wb.Name, 1, InStr(wb.Name, ".") - 1)
            .Body = "Hi," & vbNewLine & "     Please find the attachment" & vbNewLine & "Regards," &        vbNewLine & "Soumyendu"
            .Attachments.Add (wb.Path & "\" & wb.Name)
         
            .Display
        End With
    wb.Close


End sub