Microsoft Office Forums

Go Back   Microsoft Office Forums > Microsoft Word > Word VBA

Reply
 
LinkBack Thread Tools Display Modes
  #1  
Old 06-21-2012, 04:52 AM
krishnaoptif krishnaoptif is offline Windows XP Office 2007
Novice
 
Join Date: May 2012
Posts: 23
krishnaoptif is on a distinguished road
Default 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

Attached Files
File Type: doc Command_New_New.doc (42.0 KB, 3 views)
File Type: xls Excel Data.xls (24.5 KB, 2 views)

Last edited by krishnaoptif; 06-21-2012 at 06:41 AM. Reason: some changes for more clear
Reply With Quote
  #2  
Old 06-21-2012, 09:51 AM
krishnaoptif krishnaoptif is offline Windows XP Office 2007
Novice
 
Join Date: May 2012
Posts: 23
krishnaoptif is on a distinguished road
Default

Please help Experts.... This is really urgent for me.....
Reply With Quote
  #3  
Old 06-21-2012, 02:39 PM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 18,680
macropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to behold
Default

As I told you in your other thread:
Quote:
A little patience wouldn't go astray - this forum is run by volunteers and some of us need to do other things sometimes (like sleeping).
Kindly do not try to contact me for help by:
• 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
[MS MVP - Word]
Reply With Quote
  #4  
Old 06-21-2012, 05:59 PM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 18,680
macropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to behold
Default

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
[MS MVP - Word]
Reply With Quote
  #5  
Old 06-21-2012, 08:18 PM
krishnaoptif krishnaoptif is offline Windows XP Office 2007
Novice
 
Join Date: May 2012
Posts: 23
krishnaoptif is on a distinguished road
Default

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..
Reply With Quote
  #6  
Old 06-21-2012, 11:23 PM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 18,680
macropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to behold
Default

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
[MS MVP - Word]
Reply With Quote
  #7  
Old 06-22-2012, 01:05 AM
krishnaoptif krishnaoptif is offline Windows XP Office 2007
Novice
 
Join Date: May 2012
Posts: 23
krishnaoptif is on a distinguished road
Default

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
Attached Files
File Type: doc Command_New_New.doc (56.0 KB, 1 views)
File Type: xls Excel Data.xls (39.5 KB, 0 views)
Reply With Quote
  #8  
Old 06-22-2012, 02:31 AM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 18,680
macropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to behold
Default

Quote:
Originally Posted by krishnaoptif View Post
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
In that case, you could swap 'wdYellow' and 'wdRed' and change 'If iCount > 1 Then' to 'If iCount = 1 Then'
Quote:
there is some format issue in your code in my ms word line three text "probability of deletion (Pd)"
The simplest way to deal with with is to take a completely different approach. Try:
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
[MS MVP - Word]
Reply With Quote
  #9  
Old 06-22-2012, 04:47 AM
krishnaoptif krishnaoptif is offline Windows XP Office 2007
Novice
 
Join Date: May 2012
Posts: 23
krishnaoptif is on a distinguished road
Default

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....
Reply With Quote
  #10  
Old 06-22-2012, 05:08 AM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 18,680
macropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to behold
Default

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
[MS MVP - Word]
Reply With Quote
Reply

Thread Tools
Display Modes


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


All times are GMT -7. The time now is 08:26 AM.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.
SEO by vBSEO ©2011, Crawlability, Inc.
MSOfficeForums.com is not affiliated with Microsoft