Posts by jonny

Sub CleanDesktop()
    Dim fso, myFolder, myFiles, file
    Dim sfol As String, dfol As String ', file As String
    sfol = "C:\Documents and Settings\<username>\Desktop\" ' source folder path
    dfol = "E:\Miscellaneous\"                            ' destination folder path
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set myFolder = fso.GetFolder(sfol)
    Set myFiles = myFolder.Files


    On Error Resume Next
    For Each file In myFiles
        If fso.FileExists(dfol & file) Then
            fso.MoveFile (sfol & file), dfol & Int((99999 - 10000 + 1) * Rnd + 10000) & "." & file
        Else
            fso.MoveFile (sfol & file), dfol
        End If
    Next
    Set myFiles = Nothing
    Set file = Nothing
    Set fso = Nothing
End Sub

Sub CleanDesktop()


' copy list of files from Desktop to folder according


    Dim tmpName As String
    Dim rng As Range
    Dim fsoFileSearch   As Office.FileSearch       
    Dim fsoFileSearch
    Dim varFile, FileName        As Variant
    Dim FileCount As Integer
    Dim StartTime, EndTime As Date  'measure the time of a VB program that was run inside the VBA program
    Dim SourcePath, DestPath As String
    
    Dim oFs
    Dim oFile
    Dim oStream


    SourcePath = "C:\Documents and Settings\<username>\Desktop" & " \ "
    DestPath = "E:\Miscellaneous" & "\"


            On Error Resume Next    '   if such file not found, ignore it


    If oFs.FileExists(DestPath) = True Then
            FileCount = 0


            '   measure the time of a VB program that was run inside the VBA program
            StartTime = Timer
            With fsoFileSearch
                .NewSearch
                .LookIn = SourcePath
                .FileName = "*.*"
                .SearchSubFolders = True
                If .Execute() > 0 Then
                    For Each varFile In .FoundFiles
                        FileName = Split(varFile, "\")(4)
                        If Dir$(DestPath & FileName) = "" Then
                            FileCopy varFile, DestPath & FileName
'                            On Error Resume Next ' ignore any errors
                        End If
                        If Dir$(DestPath & FileName) <> "" Then
                            '   adding random prefix for exist file
                            FileCopy varFile, DestPath & Int((99999 - 10000 + 1) * Rnd + 10000) & "." & FileName
'                            On Error Resume Next ' ignore any errors
                        End If


                        ' file could be marked as readonly, you must first remove the readonly attribute from the file.
                        SetAttr varFile, vbNormal
                        Kill varFile
                        
                        FileCount = FileCount + 1
                    Next varFile
                End If
            End With
 '   measure the time of a VB program that was run inside the VBA program
    EndTime = Timer
    MsgBox ("Your files copied to " & DestPath & vbCrLf & "Copied " & FileCount & " files within " & _
    Format(EndTime - StartTime, "0.0") & " sec")
End Sub

Sub ParseWebsite()
    Application.DisplayAlerts = False
    On Error Resume Next


    For i = 1 To 10
        SiteURL = "URL;http://www.cnn.com"
            With ActiveSheet.QueryTables.Add(Connection:=SiteURL, Destination:=Range("A" & i))
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = True
                .RefreshOnFileOpen = False
                .BackgroundQuery = True
                .RefreshStyle = xlInsertDeleteCells
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .WebSelectionType = xlEntirePage
                .WebFormatting = xlWebFormattingNone
                .WebPreFormattedTextToColumns = True
                .WebConsecutiveDelimitersAsOne = True
                .WebSingleBlockTextImport = False
                .WebDisableDateRecognition = False
                .WebDisableRedirections = False
                .Refresh BackgroundQuery:=False
        End With
    Next i
    Application.DisplayAlerts = True
End Sub

End Function


Function RegExPattern(rPattern As String, rCell As String, allMatches As Boolean)
    Dim RegEx
    Dim Match As Match
    Dim Matches As MatchCollection
    Dim RetStr As String


    Set RegEx = CreateObject("vbscript.regexp")
    With RegEx
        .IgnoreCase = True
        .Pattern = rPattern
        .Global = allMatches      ' Set global applicability.
    End With
    Set Matches = RegEx.Execute(rCell)   ' Execute search.
    For Each Match In Matches      ' Iterate Matches collection.
        RetStr = RetStr & Match & " "
    Next
    If RetStr = "" Then
        RegExPattern = ""
    Else
        RegExPattern = Application.WorksheetFunction.Clean(Trim(RetStr))
    End If
End Function

Private Sub CompareArr()
    Dim rng As Range
    Dim FirstArr, SecondArr, Fir2Sec, Sec2Fir As Variant
    Dim FoundFlag As Boolean
    Dim i, j As Integer
    Dim TempValue, NewValue As String


    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select


    For Each rng In Selection
        FirstArr = Split(rng.Offset(0, 0), ",")
        SecondArr = Split(rng.Offset(0, 1), ",")
        rng.Offset(0, 2).Value = CompareTwoArr(FirstArr, SecondArr)


        FirstArr = Split(rng.Offset(0, 1), ",")
        SecondArr = Split(rng.Offset(0, 0), ",")
        rng.Offset(0, 3).Value = CompareTwoArr(FirstArr, SecondArr)
    Next rng
End Sub


Private Function CompareTwoArr(FirstArr As Variant, SecondArr As Variant)
    Dim FoundFlag As Boolean
    Dim i, j As Integer
    Dim TempValue, NewValue As String
    Dim DiffValue As String


    For i = LBound(FirstArr) To UBound(FirstArr)
        FoundFlag = True
        TempValue = ""
        For j = LBound(SecondArr) To UBound(SecondArr)
            If FirstArr(i) <> SecondArr(j) Then
                TempValue = FirstArr(i)
                FoundFlag = False
            End If
            If FirstArr(i) = SecondArr(j) Then
                FoundFlag = True
                Exit For
            End If
        Next j
        If FoundFlag = False Then
            CompareTwoArr = CompareTwoArr & "," & TempValue
        End If
    Next i
End Function

Function GetPattern(rPattern As String, rCell As String)


'   function receiving pattern and cell and retuns matching string
'
'   Example:    rCell = "abc def 1234"
'               rPattern = "[0-9]{4}"       -       4 digits
'               GetPattern = 1234
     
    Set RegEx = CreateObject("vbscript.regexp")
    RegEx.Pattern = rPattern     '"-?\d*\.\d*"
    If RegEx.test(rCell) Then
        GetPattern = RegEx.Execute(rCell)(0)
    Else
        GetPattern = "NO MATCH!" 
    End If


End Function

Set RegEx = CreateObject("vbscript.regexp")
    With RegEx
        .IgnoreCase = True
        .Pattern = rPattern
        .Global = True      ' Set global applicability.
    End With
    Set Matches = RegEx.Execute(rCell)   ' Execute search.
    For Each Match In Matches      ' Iterate Matches collection.
        RetStr = RetStr & Match & " "
      ' RetStr = RetStr & "Match found at position "
      ' RetStr = RetStr & Match.FirstIndex & ". Match Value is '"
      ' RetStr = RetStr & Match.Value & "'." & vbCrLf
    Next
    If RetStr = "" Then
        RegExPattern = "NO MATCH!"
    Else
        RegExPattern = RetStr
    End If

Function GetPattern(myPattern As String, myString As String)
    Dim regEx As RegExp
    Dim Matches As Object
    Set regEx = CreateObject("VBScript.RegExp")
    
    With regEx
        .Pattern = myPattern
        .IgnoreCase = True
    End With
    GetPattern = regEx.Replace(myString, "$1")
End Function

Function GetFolderPath() As String
    Dim oShell As Object
    Set oShell = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Select folder to retrieve files:", 0, "c:\\")
    If Not oShell Is Nothing Then
        GetFolderPath = oShell.Items.item.Path
    Else
        GetFolderPath = vbNullString
    End If
    Set oShell = Nothing
End Function

Sub SendMultEmailsWithRelevantAttachments()
    Dim olApp           As Outlook.Application
    Dim myAttachment    As Outlook.Attachment
    Dim olMail          As MailItem
    Dim ext             As String
    Dim i               As Integer


    Set olApp = New Outlook.Application


    '   using template of MS Outlook
    ChDrive "C:"
    ChDir "C:\Documents and Settings\user\Application Data\Microsoft\Templates"
    TemplateFile = Application.GetOpenFilename(Title:="select the template")
    SourcePath = GetFolderPath & "\"
    ext = InputBox("What extention of file to search (doc/xls/pdf..) ?")
    SourceFile = SourcePath & Cells(2, 2) & "." & ext


    Set olMail = olApp.CreateItemFromTemplate(TemplateFile)


    Range("a2").Select
    Range(Selection, Selection.End(xlDown)).Select
    temp = ""
    For Each rng In Selection
        i = 0
        Set olMail = olApp.CreateItemFromTemplate(TemplateFile)
        If rng.Value <> temp Then
            Do
               SourceFile = SourcePath & rng.Offset((i - 1) + 1, 1) & "." & ext
               With olMail
                   .Attachments.Add SourceFile
                End With
                i = i + 1
                temp = rng.Offset(1, 0)
            Loop While rng.Offset((i - 1) + 1, 0) = rng.Value
            With olMail
                .To = rng.Offset(0, 2) & " [" & rng.Offset(0, 5) & "]"
                .HTMLBody = "<font face='Arial' color= Navy size=2>" & "Hi " & rng.Offset(0, 3) & "," & "</font>" & .HTMLBody
                .Display
'                .send
            End With
        End If
        Set olMail = Nothing
    Next rng
    MsgBox ("Turn /.send/ methode OFF!!!")
End Sub

Sub DeleteFirstRowInWorksheet()
    Dim SheetName As Worksheet
    Dim i As Integer


    For Each SheetName In Sheets
        If Range("A1") = "table" Then
            Rows("1:1").Select
            Selection.Delete Shift:=xlUp
        End If
    Next SheetName
End Sub

Sub SendMultEmails()
  	Dim olApp           As Outlook.Application
 	Dim objOutlookAttach As Outlook.Attachments    
  	Dim olMail          As MailItem
 	Dim ext             As String
 	Dim i               As Integer
 	  
  	Set olApp = New Outlook.Application
	
  	'   template of MS Outlook
 	ChDrive "C:"
 	ChDir "C:\Documents and Settings\user\Application Data\Microsoft\Templates"
  	TemplateFile = Application.GetOpenFilename(Title:="Select the template")
 	SourcePath = GetFolderPath & "\"
  	ext = InputBox("What extention of file to search (doc/xls/pdf..) ?")


    	Set olMail = olApp.CreateItemFromTemplate(TemplateFile)
        Range("a2").Select
        Range(Selection, Selection.End(xlDown)).Select
        temp = ""
        For Each rng In Selection
            SourceFile = SourcePath & rng.Offset(0, 1) & "." & ext
            Set olMail = olApp.CreateItemFromTemplate(TemplateFile)
            With olMail
                .To = rng.Offset(0, 5)
                .HTMLBody = "<font face='Arial' color= Navy size=2>" & "Hi " & rng.Offset(0, 3) & "," & "</font>" & .HTMLBody
                i = -1
                Set objOutlookAttach = olMail.Attachments
                Do
                    temp = rng.Value
                    SourceFile = SourcePath & rng.Offset(0, 1) & "." & ext
                    objOutlookAttach.Add (SourceFile)
                    i = i + 1
                Loop Until rng.Offset(i + 1, 0) <> temp
                .Display
                .send
            End With
            temp = rng.Value
            Set olMail = Nothing
        Next rng
end sub

Sub ScanPathAndCopyExcelToWord()
    '   scan destination path for XLS files generated by SplitToFiles macros
    '   and create DOC files with a content of XLS files
    
    '   template DOC file must contain relevant BOOKMARKS!!!


    
    Dim xlsFile As Variant
    Dim DestinationPath As String
    Dim SourceFile, VarFileName As String
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    Dim BMRange1, BMRange2 As Word.Range
    Dim varFile As Variant
    
    SourceFile = Application.GetOpenFilename(Title:="Select the template DOC file to generate")
    DestinationPath = GetFolderPath
    
    With Application.FileSearch
           .NewSearch
           .LookIn = DestinationPath
           .Filename = "*.xls"
           .SearchSubFolders = True
           If .Execute() > 0 Then
                 For Each varFile In .FoundFiles
                    Workbooks.Open varFile
                    Range("A1").CurrentRegion.Copy
                    ActiveWorkbook.Close  ' SaveChanges:=False
        
                    Set wdApp = CreateObject("Word.Application")        'Create an instance of word
                    Set wdDoc = wdApp.Documents.Open(SourceFile)        'Open word file
                    
                    VarFileName = Left(varFile, Len(varFile) - 4)
                                    
                    'Set your word bookmark
                    Set BMRange1 = wdDoc.Goto(what:=wdGoToBookmark, Name:="myTable")
                    BMRange1.Paste
                    
                    Set BMRange2 = wdDoc.Goto(what:=wdGoToBookmark, Name:="mName")
                    BMRange2.InsertAfter (ExtractString(DestinationPath & "\", CStr(varFile)))


                    wdApp.ActiveDocument.SaveAs Filename:=VarFileName & ".doc", _
                        FileFormat:=wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
                    True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
                    False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
                    SaveAsAOCELetter:=False
                    wdApp.ActiveDocument.Close


                    Application.CutCopyMode = False


                    Set wdApp = Nothing
                    Set wdDoc = Nothing
                    Set BMRange1 = Nothing
                    Set BMRange2 = Nothing
                Next varFile
           End If
    End With
End Sub

Sub SplitDataToFiles()
   
    Range("B2").Select
    Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom


    With ActiveWorkbook.ActiveSheet
        Set rngCoNames = .Range("B2:B" & .Cells(Rows.count, "B").End(xlUp).Row)
    End With


    tmp = ""
    DestinationPath = "e:\Miscellaneous\Groups"
    If IsEmpty(DestinationPath) = False Then
        Kill DestinationPath & "\" & "*.*"   '   remove all files from a folder
    End If


    Application.DisplayAlerts = False
    
    For Each rngCell In rngCoNames
        If rngCell <> tmp Then
            Selection.AutoFilter Field:=2, Criteria1:=rngCell.Value
            Selection.CurrentRegion.Select
            Selection.Copy
            Workbooks.Add
            ActiveSheet.Paste
            Application.CutCopyMode = False
            Columns("A:Z").EntireColumn.AutoFit
            Rows("1:1").Select
            Selection.Font.Bold = True
            Range("A1").Select
            If InStr(rngCell.Value, "/") > 0 Then
                rngCell.Value = Replace(rngCell.Value, "/", "_")
            End If


            Columns("B:B").Select
            Selection.Delete Shift:=xlToLeft
            Range("A1").Select


            ActiveWorkbook.SaveAs FileName:= _
                DestinationPath & "\" & rngCell.Value & ".xls", FileFormat:= _
                xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
                , CreateBackup:=False
            ActiveWorkbook.Close
            Selection.AutoFilter
            tmp = rngCell
        End If
    Next rngCell
    Application.DisplayAlerts = True
    MsgBox "Group of files located in " & DestinationPath & vbCrLf, vbOKOnly + vbInformation
End Sub