When running the code getting "Object Required"
Don't have any idea to fix it..
Posts by jonny
-
-
Re: Compare two worksheets
Dear Rob,
I am trying to write some common VBA code to so it, but thanks. -
Re: Date format into Week number format
=+RIGHT(YEAR(A1),2)&WEEKNUM(A1)
..and something else, where A1 is your date. -
Required to compare two workesheets and the result to write in third worlsheet.
Attached an example that should be compared.
Explanation: 1. Worksheet "Original DB"
2. Worksheet "Customer DB"
3. Worksheet "Compare"
All comparisons I make by the car type.
In attached example the "Compare" worksheet shows the required differences.
Any idea for algorythm of VBA code will kindly appreciated. -
Re: FileSearch 2007
Thank you for your advice.
I tried to write following code, but it does not work.Code
Display MoreSub 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
Can you see the problem? -
I was using following code to clean the desktop from the files or to move files to another folder. Once the already exists in a folder it's receiving some random suffix.
Recently I installed Office 2007 and Office.FileSearch doesn't work for me. How can I change my code in order to code will start working.
Code
Display MoreSub 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
-
Re: Test String For Word & If Found, Copy Into Cell
..and if I want anyway to do it via RegEx, because the patterns may be different?
-
Re: Test String For Word & If Found, Copy Into Cell
Thanks, actually I need to extract string followed by "finance". For example: "finance: ABC", I want to extract "ABC". To do this I need RegEx, can you help?
-
I have two different functions, first is importing website to excel and the a second is testing string according to pattern. Each one of them is working ok. I'm trying to find a word "finance" in URL and put it into cell "A1".
Code
Display MoreSub 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
Code
Display MoreEnd 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
Thanks -
Re: Extract Differences Between 2 Comma Separated Range Arrays
Well done, thank you, guys!
-
Re: Extract Differences Between 2 Comma Separated Range Arrays
Thank you, really nice solution!
Another solution that I found:Code
Display MorePrivate 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
Attached a file ..The question is how to remove "commas" at the beginning?
-
Re: Extract Differences Between 2 Comma Separated Range Arrays
Thank you, friend. Very nice solution.
-
Hi guys,
I have two ranges of arrays "arr1" and "arr2".
I need to show all different elements between two arrays.Attached the sample.
Any help will be appreciated.
-
Re: Function To Return Common Words To 2 Cells
Hi all,
i think I solved the thread of myself, the code is below:Code
Display MoreFunction 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
or
Code
Display MoreSet 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
Thanks
-
Hello friends,
I'm trying to write UDF which getting RegEx pattern and a certain cell as arguments and returns only matching string.
For examples for string "The quick brown fox jumps over the lazy dog", and RegEx pattern "\w{4}" the function will return two words "OVER" and "LAZY".
What should I change in my code?Code
Display MoreFunction 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
Thank you. -
Re: Sending Multiple Attachments To Multiple Users
Dear Sir,
GetFolderPath is a function that opens a dialog box, below its code:
Code
Display MoreFunction 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
after number of trials, I changed the code to following:Code
Display MoreSub 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
Now it works , but wrong.. :(. I thing that there is a problem with a logic. May you help? -
Re: Delete Nth Row In All Worksheets If Cell Meets Criteria
Thank you , friends. Now it works!
-
Re: Delete First Row In Worksheets
Still staying on a same worksheet.., may be problem that I have ~70 worksheets?
-
I want to scan all sheets in a workbook and to delete a first row where a value in cell(1,1) is "table".
Code
Display MoreSub 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
It delete only in an active sheet. What's wrong? -
Hi Guys,
Please help with a following code. Something wrong , but I can't find an error. Code taking the name from "model" column in Excel, adding to it extention "doc" and looking it in SourcePath folder. After that it is adding to an email.
I need to add to each message all attachents where the same name in "supplier" coulmn.From example file: email to Gold will sent with two attachments (polo.doc and bora.doc), while email to Toyota will sent one attachment only (yaris.doc).
Code
Display MoreSub 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
Please advise..Thanks