Copy specific list of sub-folders form a main folder

This macro will help to copy a list of specific list of sub folders form a main folder having a many sub folders.


Code:
*********************************************************************
Private Sub CopyFolders()

    Dim FSO As Object
    Dim MyPath As String
    Dim rng As Range
    Dim Cell As Object
    Dim ToPath As String
   
    Set FSO = CreateObject("scripting.filesystemobject")
    MyPath = InputBox("Enter Source Folder")  '<< Change
    ToPath = InputBox("Enter Destination Folder")
    If Right(MyPath, 1) = "\" Then
        MyPath = Left(MyPath, Len(MyPath) - 1)
    End If

    If FSO.FolderExists(MyPath) = False Then
        MsgBox MyPath & " doesn't exist"
        Exit Sub
    End If

Set rng = Application.InputBox(prompt:="Select the cells containg the file names", Title:="Select Range of Cells", Type:=8)
    On Error Resume Next
    For Each Cell In rng
        FSO.CopyFolder MyPath & "\" & Cell.Value, ToPath & "\" & Cell.Value
    Next Cell
End Sub
********************************************************************* 

Copy specific list of files form a group of files to specified folder

This macro will help you to copy specific list of files form a folder containing many files.

Code:
*********************************************************************
Private Sub CopyFiles()
    Dim myfilesystemobject As Object
    Dim myfiles As Object
    Dim myfile As Object
    Dim rng As Range
    Dim Cell As Object
    Dim strDirectory As String
    Dim strDestFolder As String
   
    strDirectory = InputBox("Enter Source Folder")
    strDestFolder = InputBox("Enter Destination Folder")
   
    Set rng = Application.InputBox(prompt:="Select the cells containg the file names", Title:="Select Range of Cells", Type:=8) 'set this to the range of your filtered list
    Set myfilesystemobject = CreateObject("Scripting.FileSystemObject")
    Set myfiles = myfilesystemobject.GetFolder(strDirectory).Files
       
    On Error Resume Next
    For Each Cell In rng
        For Each myfile In myfiles
            If Not IsNull(Cell.Value) Then
                If myfile = strDirectory & "\" & Cell.Value & ".tagged.xml" Then
                    With myfile
                        .Copy strDestFolder & "\" & myfile.Name
                    End With
                Else
                End If
            End If
        Next myfile
    Next Cell
End Sub
*********************************************************************

Search selected cell from excel using your favorite browser and search engine

This macro will help you to search with the content of the selected cell from word doc directly in google or any other site easily.
Simply select the text and run the macro your search result will appear in your favorite browser.
Note:
1.Change the Path to your browser (firefox, IE, chrome etc.,) installation path.
2.To search other website change the Link to your favorite search engine.
3.Select only single cell.

Code:
*********************************************************************
Sub googlesearch()

Dim x As Variant
Dim Path As String
Dim Link As String
Dim TheTerm As String

TheTerm = excel.selection

    Path = "C:\Program Files\Mozilla Firefox\firefox.exe"

    'for internet explorer change the path to "C:\Program Files\Internet Explorer\iexplore.exe"

    Link = "http://www.google.com/search?num=20&hl=en&q=" & TheTerm
    'for searching with Bing change the Link to "http://www.bing.com/search?q="

    x = Shell(Path + " " + Link, vbNormalFocus)

End Sub
*********************************************************************

Search selected term from word doc using your favorite browser and search engine

This macro will help you to search the selected word from word doc directly in google or any other site easily.
No need to copy the text from word open google and paste the word in search box and search.
Its very simple select the text and run the macro your search result will appear in your favorite browser.

Note:
1.Change the Path to your browser (firefox, IE, chrome etc.,) installation path.
2.To search other website change the Link to your favorite search engine.
Code:

*********************************************************************
Sub googlesearch()

Dim x As Variant
Dim Path As String
Dim Link As String
Dim TheTerm As String

If Selection.Type = wdSelectionIP Then
TheTerm = Selection.Words(1).Text
Else
TheTerm = Selection.Text
End If
TheTerm = Trim(TheTerm)

    Path = "C:\Program Files\Mozilla Firefox\firefox.exe"

    'for internet explorer change the path to "C:\Program Files\Internet Explorer\iexplore.exe"

    Link = "http://www.google.com/search?num=20&hl=en&q=" & TheTerm
    'for searching with Bing change the Link to "http://www.bing.com/search?q="

    x = Shell(Path + " " + Link, vbNormalFocus)

End Sub
*********************************************************************

Log in to google or facebook account using excel

Login to Google Account using VBA

Have you ever thought of automating your login to google account or any other account using excel macros?

Hear is the simple macro to log in to google account.

Note: Change to your user name and password.

Code: For google account
****************************************************
Sub Login_google()
    
    Dim ie As Object
    
    Set ie = CreateObject("InternetExplorer.Application")
    
    ie.navigate "https://www.google.com/accounts/Login"
    
    ie.Visible = True
    
    Do While ie.Busy And Not ie.readyState = 4
        DoEvents
    Loop
    
    DoEvents
    
    ie.document.all.Item("Email").Value = "Rajendiran"
    ie.document.all.Item("passwd").Value = "******"
    ie.document.all.Item("signIn").Click
    
End Sub

****************************************************

 Code: For Facebook account

****************************************************
Sub Login_facebook()
    
    Dim ie As Object
    
    Set ie = CreateObject("InternetExplorer.Application")
    
    ie.navigate "http://www.facebook.com/login.php"
    
    ie.Visible = True
    
    Do While ie.Busy And Not ie.readyState = 4
        DoEvents
    Loop
    
    DoEvents
    
    ie.document.all.Item("email").Value = "rajendiran@mymail.com"
    ie.document.all.Item("pass").Value = "*******"
    ie.document.all.Item("login").Click
    
End Sub

****************************************************

Remove Duplicates From Selected Cells

This macro is useful for removing duplicates on the selected data.

*************************************************************************
Code:

Sub RemoveDuplicate()


Dim ConstRange As Range, FrmRange As Range
Dim FullRange As Range, rCell As Range
Dim iCount As Long
Dim strAdd As String

DialogStyle = vbYesNo + vbCritical + vbDefaultButton2
Title = "Deleting Duplicates"
Msg = "Are you sure you want to delete entire rows?"
deleteDupRows = MsgBox(Msg, DialogStyle, Title)

If deleteDupRows = vbYes Then
   
    On Error Resume Next

    Set FullRange = Selection
        If WorksheetFunction.CountA(FullRange) < 2 Then
            MsgBox "Select more than one cell", vbInformation
            On Error GoTo 0
            Exit Sub
        End If

    Set ConstRange = FullRange.SpecialCells(xlCellTypeConstants)
    Set FrmRange = FullRange.SpecialCells(xlCellTypeFormulas)

    If Not ConstRange Is Nothing And Not FrmRange Is Nothing Then
        Set FullRange = Union(ConstRange, FrmRange)
    ElseIf Not ConstRange Is Nothing Then
        Set FullRange = ConstRange
    ElseIf Not FrmRange Is Nothing Then
        Set FullRange = FrmRange
    Else
        MsgBox "Invalid Selection", vbInformation

        On Error GoTo 0
       
        Exit Sub
   
    End If

    Application.Calculation = xlCalculationManual

    For Each rCell In FullRange

        strAdd = rCell.Address
        strAdd = FullRange.Find(What:=rCell, After:=rCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Address

        If strAdd <> rCell.Address Then
            rCell.Clear
        End If

    Next rCell

End If
 

    Application.Calculation = xlCalculationAutomatic

    On Error GoTo 0

End Sub

*************************************************************************

Create Hyperlink for filenames or folder names from the cells in excel

This macro is to create hyperlinks to a list of file names in the excel to a specific folder containing the list of files

For example I have a folder containing thousands of subfolders and I have the list of sub folders present in that folder.
I have to specific folders and open it for which i would generally use to search the "Main folder" for the "Sub folder" and open it each time since the folder has thousands of sub folder the search takes a lot of time.
Here is a easy way to solve my problem.
I create a hyper link in excel to only the specific sub folders which i have to check and open them by clicking the hyperlink.


Note: Please take care that the the list of folder names you want to create hyperlink is present in "Sheet1" and in Column "A" or else you can modify the code according to your need.
Provide the Main folder path in the Input Box when it pop ups.

For any assistance please post me.

Here is the code for hyperlinking.

****************************************************************

Code:

Sub Create_Hyperlink()

Dim Path As String
Dim lastRow As Long
Dim rOffset As Long
Dim partialPath As String
Dim linkPath As String

Path = InputBox("Please paste the path to which the list should be hyperlinked")
 
  Const SheetToPutLinksOn = "Sheet1"
  Const ColumnWithFileNames = "A"
  Const firstFilenameRow = 1

  ThisWorkbook.Worksheets(SheetToPutLinksOn).Activate
  Application.ScreenUpdating = True
  partialPath = Path & "\"
  lastRow = Range(ColumnWithFileNames & Rows.Count).End(xlUp).Row - _
   firstFilenameRow
  Range(ColumnWithFileNames & firstFilenameRow).Select
  Application.ScreenUpdating = True
  For rOffset = 0 To lastRow
     If Not IsEmpty(ActiveCell.Offset(rOffset, 0)) Then
      linkPath = partialPath & ActiveCell.Offset(rOffset, 0).Text
      ActiveSheet.Hyperlinks.Add anchor:=ActiveCell.Offset(rOffset, 0), _
       Address:=linkPath
    End If
  Next
  ThisWorkbook.Saved = True
  Application.ScreenUpdating = True

End Sub

****************************************************************