|
|
Thread Tools | Display Modes |
#1
|
|||
|
|||
replace data from variable with "sub and super script" from excel to word by vba
Hi Experts,
Pelase change my code... when i am storing excel cell value in variable and replaceing data in MS word with the same variable then this code change "subSubscript and super script" data as normal text... but i need same data in ms word like as in Excel cell with "sub and super script"... Pelase find attached my word and excel file and run macro from ms word.. and pick excel file accordingly.. ms word vba passord is --- kk Please help Code:
Sub ReplaceExcelCellvalueInMswordFile() Dim wdApp As Word.Application Dim wdDoc As Word.Document Dim SrcWb As Workbook Dim SrcWs As Worksheet Dim arrCnt As Integer Dim LastCol As Long Dim LastRow As Long Dim NxtRow As Long Dim arrFiles As Variant Dim FName As String Dim FilesPath As Variant Dim r, RR, RRR, R4, c, RecordCount, RecordCount_2, NewRecord, P, BreakLoop, OneRecordFill As Integer Dim Sum_AMT, Count_GL, Count_MISGrouping As Double Dim MISgroupName As Variant Dim str, str2, str3, str4 As String Dim iCount As Long Dim strSearch1, strSearch2, strReplace As String Const YOUR_REQUIRED_COLOR_IDX As Integer = 6 'RED' Dim doc As Range Set doc = ActiveDocument.Range 'File picker Dim dlg As Variant Dim dataPath As Variant Set dlg = Application.FileDialog(msoFileDialogFilePicker) dlg.Title = "Select your MS word File for replace the word" dlg.AllowMultiSelect = False If dlg.Show = -1 Then dataPath = dlg.SelectedItems(1) 'Me!browseDataPath.Value = dataPath End If Set SrcWb = Workbooks.Open(dataPath, False, True) Set SrcWs = SrcWb.Sheets("DATA") With SrcWs 'Count the word r = 2 str = SrcWs.Cells(r, 1).Value While str <> "" strSearch1 = SrcWs.Cells(r, 1).Value strSearch2 = SrcWs.Cells(r, 2).Value & " (" & SrcWs.Cells(r, 2).Value & ")" strReplace = SrcWs.Cells(r, 2).Value iCount = 0 Application.Options.DefaultHighlightColorIndex = wdRed With ThisDocument.Content.Find .Text = strSearch1 .Replacement.Text = strReplace .Replacement.Highlight = True .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With Application.Options.DefaultHighlightColorIndex = wdRed With ThisDocument.Content.Find .Text = strSearch2 .Replacement.Text = strReplace .Replacement.Highlight = True .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With iCount = 0 'Count the word and color With ThisDocument.Content.Find .Text = strReplace .Highlight = True .Wrap = wdFindStop Do While .Execute iCount = iCount + 1 Loop End With If iCount > 1 Then Application.Options.DefaultHighlightColorIndex = wdYellow With ThisDocument.Content.Find .Text = strReplace .Replacement.Text = strReplace .Highlight = True .Replacement.Highlight = True .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With End If r = r + 1 str = SrcWs.Cells(r, 1).Value Wend SrcWb.Close False End With Set SrcWs = Nothing Set SrcWb = Nothing MsgBox "Done" End Sub Last edited by krishnaoptif; 06-21-2012 at 06:41 AM. Reason: some changes for more clear |
#2
|
|||
|
|||
Please help Experts.... This is really urgent for me.....
|
#3
|
||||
|
||||
As I told you in your other thread:
Quote:
• replying to other threads; or • private messaging, with links to you latest thread. It will not get you a response any sooner. If you paid any attention to my profile page, you would realise that your post and PM were late at night for me.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#4
|
||||
|
||||
I've had a look at you documents. It seems I wasted my time giving advice in your other thread, as you clearly haven't implemented the code I provided.
As for your current problem, you cannot use a string variable for a Find/Replace where part of either the Find criterion or the Replace criterion has any kind of formatting applied. You could try copying the Excel cell (ie SrcWs.Cells(r, 2).Copy) and using '.Replacement.Text = "^c"', but that will result in the replacement containing your replacement content in a table cell, which you'd then have to convert to text.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
|||
|
|||
Hi Mr Macropod,
I am really sorry about that.... Now when i am using your above logic...that works great but There is a formatting issue and some logic not work perfectly.... Can you test my word doc vba code and run with your logic... you will get actual problem.... sorry again Mr Macropod.. |
#6
|
||||
|
||||
Try:
Code:
Dim iCount As Long, r As Long Dim strSearch, strReplace As String With SrcWs 'Count the word r = 2 strSearch = SrcWs.Cells(r, 1).Value While strSearch <> "" strReplace = SrcWs.Cells(r, 2).Value SrcWs.Cells(r, 2).Copy Application.Options.DefaultHighlightColorIndex = wdYellow With ThisDocument.Content With .Find .ClearFormatting .Replacement.ClearFormatting .Format = False .MatchCase = False .MatchWholeWord = True .Wrap = wdFindContinue .Text = strSearch & "^w(" & strReplace & ")" .Replacement.Text = strSearch .Execute Replace:=wdReplaceAll .Text = strSearch .Replacement.Text = "^c" .Replacement.Highlight = True .Execute Replace:=wdReplaceOne End With While .Find.Found .Duplicate.Tables(1).ConvertToText Separator:=wdSeparateByTabs .Duplicate.Characters.Last.Delete .Find.Execute Replace:=wdReplaceOne Wend End With strSearch = ThisDocument.Range.Text iCount = (Len(strSearch) - Len(Replace(strSearch, strReplace, ""))) / Len(strReplace) If iCount > 1 Then Application.Options.DefaultHighlightColorIndex = wdRed With ThisDocument.Content.Find .Text = strReplace .Replacement.Text = "^&" .Highlight = True .Replacement.Highlight = True .Wrap = wdFindContinue .Execute Replace:=wdReplaceOne End With End If r = r + 1 strSearch = SrcWs.Cells(r, 1).Value Wend SrcWb.Close False End With
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#7
|
|||
|
|||
Mr Paul,
Now my logic has been chaged... if any text replaced is one time in document then will be red and if more then one time then that will be yellow for all..... this is in my code i think you did not see that... Your This code is working like my first logic for the red and yeallow color...and also there is some format issue in your code in my ms word line three text "probability of deletion (Pd)" Now i have apply you code in my doc VBA project.... Pelase check the attached files and run...then you will find the line three problm and color code change... and Third logic is which used in my code.... if text is Visual Basic (VBA) in MS word and i have to change Visual Basic to VBA then it will be after replace VBA (VBA) but i need only one VBA... so if it is VBA (VBA) then again should be replace by VBA only.. Then final result is VBA |
#8
|
||||
|
||||
Quote:
Quote:
Code:
Application.ScreenUpdating = False Dim lRow As Long, lTbl As Long Dim RngFnd As Range, RngRep As Range, RngSrch As Range Dim StrFnd As String, StrRep As String, StrSrch As String With SrcWb SrcWs.UsedRange.Copy .Close False End With DoEvents Set SrcWs = Nothing: Set SrcWb = Nothing With ThisDocument .Range.InsertAfter vbCr .Characters.Last.Paste DoEvents lTbl = .Tables.Count Set RngSrch = .Range(0, .Tables(lTbl).Range.Start) For lRow = 2 To .Tables(lTbl).Rows.Count Set RngFnd = .Tables(lTbl).Rows(lRow).Cells(1).Range RngFnd.End = RngFnd.End - 1 StrFnd = Trim(RngFnd.Text) Set RngRep = .Tables(lTbl).Rows(lRow).Cells(2).Range RngRep.End = RngRep.End - 1 RngRep.Copy StrRep = Trim(RngRep.Text) Application.Options.DefaultHighlightColorIndex = wdRed With RngSrch.Find .ClearFormatting .Replacement.ClearFormatting .Format = False .MatchCase = False .MatchWholeWord = True .Wrap = wdFindContinue .Text = StrFnd & "^w(" & StrRep & ")" .Replacement.Text = StrFnd .Execute Replace:=wdReplaceAll .Text = StrFnd .Replacement.Text = "^c" .Replacement.Highlight = True .Execute Replace:=wdReplaceAll End With StrSrch = RngSrch.Text If (Len(StrSrch) - Len(Replace(StrSrch, StrRep, ""))) / Len(StrRep) = 1 Then Application.Options.DefaultHighlightColorIndex = wdYellow With RngSrch.Find .Text = StrRep .Replacement.Text = "^&" .Highlight = True .Replacement.Highlight = True .Wrap = wdFindContinue .Execute Replace:=wdReplaceOne End With End If Next .Tables(lTbl).Delete .Characters.Last.Delete End With Set RngSrch = Nothing: Set RngFnd = Nothing: Set RngRep = Nothing Application.ScreenUpdating = True MsgBox "Done"
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#9
|
|||
|
|||
Mr Macropod,
I am not able to connect with this highlevel code... because i am not an expert in vba code much... This is request you to Please .... may you do the same changes in my ms word doc vba code and test with it with excel file for the all three logics.... and Pelase send me that updated file... That will help me.....because would be complete solution for me... I am really sorry for distrubing again and again for the same.... |
#10
|
||||
|
||||
The code I posted replaces everything between 'Set SrcWs = SrcWb.Sheets("DATA")' and 'End Sub'.
I would be reluctant to make any other changes to your code because it has a lot of variables that aren't used in what you've posted, so I don't know how they are relevant.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
How to "replace" a word with same word but "Italic"? | Jamal NUMAN | Word | 4 | 07-08-2011 04:02 AM |
How to use "if" to copy and paste data | tareq | Excel Programming | 13 | 01-26-2011 03:34 PM |
Rules and Alerts: "run a script"? | discountvc | Outlook | 0 | 06-15-2010 07:36 AM |
An "error has occurred in the script on this page" | decann | Outlook | 8 | 09-03-2009 08:54 AM |
Saving only "DATA" on excel? No white bottom? | jrasche2003@yahoo.com | Excel | 0 | 08-07-2006 09:27 AM |