Re: Date format into Week number format
=+RIGHT(YEAR(A1),2)&WEEKNUM(A1)
..and something else, where A1 is your date.
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.
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
Display More
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.
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
Display More
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".
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
Display More
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
Display More
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:
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
Display More
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:
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
Display More
or
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
Display More
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?
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
Display More
Thank you.
Re: Sending Multiple Attachments To Multiple Users
Dear Sir,
GetFolderPath is a function that opens a dialog box, below its code:
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
Display More
after number of trials, I changed the code to following:
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
Display More
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".
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
Display More
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).
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
Display More
Please advise..
Thanks
Re: Generating New Files According To Data
Following macro scan xls files from "DestinationPath" , copy file content to doc taken from template.doc and save it in "DestinationPath" folder.
I wrote something like, but in a row of "'Open word file
" it is working very slowly
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
Display More
Guys, please assist to find what's wrong..
Hi Guys, I have a follwoing code that split data from a worksheet to new Excel files where the column "B" is a file name.
Running macro on attached excel file will create three new files: Ford.xls, Toyota.xls, Wolkswagen.xls. The content of each file will be its models.
In order to create new excel file with a copied data, I need to generate doc files and to append relevant data in the word file. The data must be appended between a template strings Text1 and Text2 (a doc file attached).
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
Display More
Any solution will be kindly appreciated..