I have a .txt file that needs to be cleaned up. It needs to have a page break before the word "Individual" on every page. It also needs to be Courier New 8.5pts, top and bottom margin of 0.5in, left and right margin of 1in. I modified another script I found (shown below) and it almost gets me there. the problem is there is some unneeded text before "Individual", which is the number 1 followed by several spaces and 3 carraige returns. I need to delete this text. Below is the script as it is currently:
Sub InsertPageBeforeDate()
Dim lngPos As Long
Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory
Selection.WholeStory
Selection.Font.Name = "Courier New"
Selection.Font.Size = 8.5
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Individual"
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
Do While .Execute
If Selection.Information(wdFirstCharacterLineNumber) > 1 Then
lngPos = Selection.Start
Selection.MoveLeft Unit:=wdWord, Count:=2, Extend:=True
If LCase(Selection.Text) <> "of " Then
Selection.Collapse Direction:=wdCollapseEnd
Selection.InsertBreak Type:=wdPageBreak
End If
ActiveDocument.Range(Start:=lngPos + 4, End:=lngPos + 4).Select
End If
Loop
End With
Application.ScreenUpdating = True
End Sub
Related
I would like to know if there is a way to create hyperlinks from a text in bulk.
I have the following text:
www. abc .com/pictures/T_1.jpg
www. abc. com/pictures/T_2.jpg
www. abc. com/pictures/T_3.jpg
www. abc. com/pictures/T_4.jpg
Each text is a link in its own right, but if I select all and press Ctrl+K, I cannot create a hyperlink that takes the text as a weblink. I can do it one by one. If I select any of the text and press Ctrl+K, it'll give me www.abc.com/pictures/T_1.jpg as the web address for that link, but not in bulk. How to do it?
Note: spaces in the links to avoid posting errors.
Please try this,
Paste links in word and separate them by a paragraph,
Select the links and Insert -> Table -> Convert to Table,
View -> Macros -> View Macros and create the following macro named BH
Sub BH()
Dim Rng As Range, TblCell As Cell, StrTxt As String
With Selection
If .Information(wdWithInTable) = False Then Exit Sub
For Each TblCell In .Cells
Set Rng = TblCell.Range
With Rng
.End = .End - 1
StrTxt = .Text
.Text = ""
End With
ActiveDocument.Hyperlinks.Add Anchor:=Rng, _
Address:="Address", SubAddress:="SubAddress", _
ScreenTip:="", TextToDisplay:=StrTxt, Target:="_blank"
Next
End With
End Sub
For what you have described:
Sub ConvertURLTextsToHyperlinksInDoc()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[wh][wt][wtps]{1,3}[./][!^13^t^l ^s]{1,}"
.Replacement.Text = ""
.Forward = True
.Format = False
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
If .Characters.Last Like "[:;.,(?)!})]" Then .End = .End - 1
.Hyperlinks.Add .Duplicate, .Text, , , .Text
.Start = .Hyperlinks(1).Range.End
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
The text you posted, though, does not include valid URLs - there are spaces either side of abc...
I have a question about finding and replacing all numbers in a word document.
I have numbers from 59...~600 or so, and I want to increment all of them by a fixed number. I'm not at all familiar with word macros.
You could use a macro like:
Sub Demo()
Application.ScreenUpdating = False
Const i As Long = 50
With ActiveDocument.Range
With .Find
.ClearFormatting
.Text = "<[0-9]{2,3}>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
If CLng(.Text) > 58 Then
If CLng(.Text) < 700 Then .Text = CLng(.Text) + i
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
where 50 in the above code is the amount you want to increment the other numbers by. Note that, given your specifications, the above will only process numbers between 58 and 700.
Hello Friends I have a problem with Quotation marks, so my problem is:
I have a word document (about 100 pages) and want to change quotation marks with (Find and replace), but word can't understand what I need.. here is my example....
"Test Word" you see the quotation marks I want to change them with „Test Word“ (This is the Quotation mark which used In Georgian Language).. Can you help to overcome this problem... (I also tried to use codes like ^0132) but the result is the same.
Thank you In Advanced!
It's easy, open the document and run the following macro:
Sub TestFormatQuotes()
Selection.WholeStory
Selection.LanguageID = wdGeorgian
Selection.Range.AutoFormat
End Sub
This will select the whole document, set the language to Georgian and by running AutoFormat the quotes will automagically be replaced by the lower left and upper right quotes.
You can do this manually, by adding the AutoFormat button to the Quick Access Toolbar using File-Options-Quick Access Toolbar, and select "Commands not in the Ribbon" on the left list. If your AutoFormat settings are right (check the options on the AutoFormat dialog, AutoFormat Tab, Replace, "Straight Quotes" to "Smart Quotes" option enabled) this will automagically replace all the straight quotes.
Here is an example with the option to fully restore the straight quotes before replaceing using AutoFormat. I tested this on your question text above and worked with me.
Sub testquotes()
Selection.WholeStory
Dim ReplaceQuotes As Boolean
ReplaceQuotes = Application.Options.AutoFormatReplaceQuotes = False
Dim ReplaceQuotesAsYouType As Boolean
ReplaceQuotesAsYouType = Application.Options.AutoFormatAsYouTypeReplaceQuotes = False
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
' Alt-0132
With Selection.Find
.Text = "„"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
' Alt-0147
With Selection.Find
.Text = "”"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
' Alt-0148
With Selection.Find
.Text = "“"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'---Comment This part to revert to straight quotes
Application.Options.AutoFormatReplaceQuotes = True
Application.Options.AutoFormatAsYouTypeReplaceQuotes = True
Selection.LanguageID = wdGeorgian
Selection.Range.AutoFormat
'---Comment This part to revert to straight quotes
Application.Options.AutoFormatReplaceQuotes = ReplaceQuotes
Application.Options.AutoFormatAsYouTypeReplaceQuotes = ReplaceQuotesAsYouType
End Sub
I'm using Ron de Bruins code for emailing many different files to different people, as shown below. But the issue I have is, if an email address exists in column B and the corresponding workbook doesn't exist it still creates an email but with no attachment, as there isn't one. Would anyone know how to modify the code so that if a workbook didn't exist it doesn't create the email?
Sub Send_Files()
'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
You can set a flag to go to the next item if the file does not exist:
Dim noFile as Boolean
noFile = True
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
noFile = False
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
if Not noFile then .Send
There are other ways to do this (see for example Sidharth Rout's suggestion which checks for the existence of files before even starting to create the email); I chose the above because it minimizes the amount of change needed in your existing code (just three lines, easy to see what they do).
Some people would prefer to invert the logic, with a hasFile boolean:
Dim hasFile as Boolean
hasFile = False
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
hasFile = True
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
if hasFile then .Send
I have about 40 workbooks with 1000+ columns and near 1 million records.
Unfortunately, most of the data was imported as a text format, and I am trying to convert particular columns to a number format.
Aside from manually editing every file using the paste special > multiply technique, is there a way to macro this so that it would iterate through all the excel files in a particular folder?
You know the columns and numbers to change. You can record a macro of that and insert it into this basic DIR() technique:
Option Explicit
Sub LoopThroughFolder()
Dim fPATH As String, fNAME As String
Dim wb As Workbook
fPATH = "C:\Path\To\My\Files\" 'remember the final \
fNAME = Dir(fPATH & "*.xl*") 'get first filename from fPATH
Application.ScreenUpdating = False 'speed up execution
Do While Len(fNAME) > 0
Set wb = Workbooks.Open(fPATH & fNAME)
'your code here to format that activesheet
wb.Close True 'save and close the edited file
fNAME = Dir 'get the next filename
Loop
Application.ScreenUpdating = True
End Sub
Option Compare Database
Public Function format(filepath, sheetname, sheetpath)
Set xls = CreateObject("EXCEL.APPLICATION")
xls.screenupdating = False
xls.displayalerts = False
xls.Visible = True
xls.workbooks.Open filepath
Set xlsdd = xls.ActiveWorkbook
'deleting headers
xls.Range("1:1").Select
xls.Selection.Delete Shift:=xlUp
'adding one column
xls.Columns("A:A").Select
xls.Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'adding 5 rows
'ActiveWorkbook.Sheets("sheet1").Select
xls.Rows("1:5").Insert Shift:=xlDown
' fetching rows from access and putting them into excel
' strsql = "select top 5 " & sheetname & ".* into top5_records from " & sheetname
' DoCmd.RunSQL strsql
' outputFileName = "C:\Users\hp\Desktop\top5_records.xls"
' DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "top5_records", outputFileName, True
'then open that excel and copy the rows
Set xls2 = CreateObject("EXCEL.APPLICATION")
xls2.screenupdating = False
xls2.displayalerts = False
xls2.Visible = True
xls2.workbooks.Open sheetpath
Set xlsdd2 = xls2.ActiveWorkbook
xls2.Rows("1:5").Select
xls2.Selection.Copy
xls.Cells(1, 1).Select
xls.activesheet.Paste
'making first 6th row to be bold
xls.Rows("6:6").Select
With xls.Selection.Font
.Bold = True
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
End With
'autofit the data
xls.Sheets(sheetname).Cells.Columns.autofit
xls.CutCopyMode = False
'making both the excel objects to be free
With xlsdd
.Save
.Close
End With
xls.Visible = False
Set xlsdd = Nothing
Set xls = Nothing
With xlsdd2
.Save
.Close
End With
xls2.Visible = False
Set xlsdd2 = Nothing
Set xls2 = Nothing
End Function