Posts by ArdusPetus

Option Explicit

Sub Replace()

Dim wOR As Worksheet, wRR As Worksheet
Dim rngIn As Range
Dim tabRepl As Variant
Dim i As Long
    Set wOR = Worksheets("Original Range")
Set wRR = Worksheets("Replace Range")

tabRepl = wRR.[A1].CurrentRegion

For Each rngIn In Range(wOR.[A2], wOR.Cells(Rows.Count, "A").End(xlUp))
    For i = LBound(tabRepl) To UBound(tabRepl)
        If InStr(1, rngIn, tabRepl(i, 1)) > 0 Then
            wOR.Cells(rngIn.Row, "C") = tabRepl(i, 1)
            wOR.Cells(rngIn.Row, "E") = tabRepl(i, 2)
            wOR.Cells(rngIn.Row, "G") = Strings.Replace(rngIn, tabRepl(i, 1), tabRepl(i, 2))
            Exit For
        End If
    Next i
Next rngIn
End Sub
[attach=1227660][/attach]

HTH,
-- 
AP

Option Explicit


Dim Counter As Long
Const MAXCHANGES As Long = 10


Private Sub Worksheet_Change(ByVal Target As Range)
Counter = Counter + 1
If Counter > MAXCHANGES Then
    Application.StatusBar = "Saving..."
    Me.Parent.Save
    Counter = 0
    Application.StatusBar = "Done!"
End If
End Sub

Option Explicit

Sub LoopPDFsInFolder()
    Dim wb As Workbook
    Dim myPath As String
    Dim myFile As String
    Dim myExtension As String
    Dim r As Long
    Dim WApp As Object
    Dim WDoc As Object
    Dim WDR As Object
    Dim ExR As Range
    
    ' Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    
    myPath = "c:\users\laurent\documents\perso\"
    myExtension = "*.PDF*"
    myFile = Dir(myPath & myExtension)
    
    Set WApp = CreateObject("Word.Application")
    WApp.Visible = True
    
    r = 0
    
    On Error GoTo ResetSettings
    Do While myFile <> "" 'Loop through each Excel file in folder
        Set ExR = Selection ' current location in Excel Sheet
        Set WDoc = WApp.Documents.Open(myPath & myFile)
        WApp.Selection.HomeKey Unit:=6
        WApp.Selection.Find.ClearFormatting
        WApp.Selection.Find.Execute "In the matter of the" 'find key phrase
        WApp.Selection.MoveDown Unit:=5, Count:=1
        WApp.Selection.HomeKey
        WApp.Selection.MoveRight Unit:=3, Count:=1, Extend:=1
        Set WDR = WApp.Selection ' copy selected sentence to excel
              
        ExR(1, 1).Offset(r, 0) = WDR ' place below selected cell
        r = r + 1
        
        WDoc.Close
        
        myFile = Dir 'Get next file name
    Loop
    
ResetSettings:
    WApp.Quit
    
    Set WApp = Nothing
    Set WDoc = Nothing
    Set WDR = Nothing
    
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Done!"

End Sub