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
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.
I would like to filter results at sheet and create Listbox with this result,
this code works on listbox on sheet but not works on form, any idea ?
Sub MyListBox()
Dim rng As Range
Dim vArr As Variant
Dim ListBox1 As Object ---> this works on sheet but not works on form
Dim x As Single
Dim y As String
y = Worksheets("Sheet2").Cells(1, 12).Value
x = Worksheets("Sheet2").Cells(2, 12).Value
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Set rng = Range("TestMaterial")
Set ListBox1 = ActiveSheet.OLEObjects(1).Object ---> this works on sheet but not works on form
rng.AutoFilter field:=13, Criteria1:=y
rng.AutoFilter field:=12, Criteria1:=x
Worksheets.Add
rng.SpecialCells(xlCellTypeVisible).Copy Range("a1")
vArr = ActiveSheet.UsedRange
With ListBox1
.List = (vArr)
End With
ActiveSheet.Delete
Worksheets("TRAINING").AutoFilterMode = False
'rng.AutoFilter.Clear
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
I found this code but this creates new listbox but do not fill listbox with data, only headers, could not find what is incorrect and how can I fill existing listbox with this code ?
Sub MyListBox()
Dim rng As Range
Dim vArr As Variant
Dim ListBox1 As MSForms.Control
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Set rng = Range("TestMaterial")
Set ListBox1 = frmplan.Controls.Add("Forms.ListBox.1") ---> adds new Listbox to form even I have some one with name "Listbox1"
rng.AutoFilter field:=13, Criteria1:=txtsdept.Value
rng.AutoFilter field:=12, Criteria1:=txtsgrade
Worksheets.Add
rng.SpecialCells(xlCellTypeVisible).Copy Range("a1")
vArr = ActiveSheet.UsedRange
With ListBox1
.List = (vArr)
End With
ActiveSheet.Delete
Worksheets("TRAINING").AutoFilterMode = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
try the following code for the "Userform" case:
Sub MyListBox()
With Range("TestMaterial")
.AutoFilter Field:=13, criteria1:=txtsdept.value
.AutoFilter Field:=12, criteria1:=txtsgrade
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then FillListBox .SpecialCells(xlCellTypeVisible), Me.ListBox1
.Parent.AutoFilterMode = False
End With
End Sub
Sub FillListBox(filteredRng As Range, LB As msforms.ListBox)
Dim vArr As Variant
vArr = GetArray(filteredRng) '<--| fill array
With LB
.ColumnCount = UBound(vArr, 2)
.List = vArr
End With
End Sub
Function GetArray(filteredRng As Range) As Variant
Dim calculation As XlCalculation
ApplicationBoost True, calculation '<--| boost application "up"
With filteredRng
Worksheets.Add
.Copy Range("A1")
GetArray = ActiveSheet.UsedRange '<--| fill returned array
Application.DisplayAlerts = False '<--| disable alerts for what strictly needed
ActiveSheet.Delete
Application.DisplayAlerts = True '<--| enable alerts back
End With
ApplicationBoost False, calculation '<--| boost application "back"
End Function
Sub ApplicationBoost(boost As Boolean, calculation As XlCalculation)
With Application
If boost Then
calculation = .calculation '<--| retrieve current calculation setting
.calculation = xlCalculationManual '<--| turn calculation off
Else
.calculation = calculation '<--| restore current calculation setting
End If
.ScreenUpdating = Not boost
.EnableEvents = Not boost
End With
End Sub
as you can see, I refactored your code and split in more little bits you can more easily handle and both enhance and maintain your code
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
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