Dear Macropod,
I tried your code & it is working. But some values do not copy (only part of the text) to my excel sheet (Summary).
This is my Code :
Sub Split_Thirdparty_Letters_pdf()
Dim xlApp As Object
Dim xlWbk As Object
Dim xlWsh As Object
Dim xlRng As Object
Dim lngStart As Long
Dim lngEnd As Long
Dim lngDocNum As Long
Dim docOld As Document
Dim docNew As Document
Dim sText As String
Dim sText2 As String
Dim sTotal As String
Dim sDirectory As String
On Error Resume Next
Set xlApp = GetObject(Class:="Excel.Application")
If xlApp Is Nothing Then
Set xlApp = CreateObject(Class:="Excel.Application")
End If
On Error GoTo 0
' Add path to workbook if necessary
Set xlWbk = xlApp.Workbooks.Open("C:\Users\User\Desktop\Thirdp arty Payments\Thirdparty Remitance.xlsm")
Set xlWsh = xlWbk.Worksheets("Thirdparty")
Set docOld = ActiveDocument
lngStart = 1
selection.HomeKey Unit:=wdStory
With selection.Find
.ClearFormatting
.Text = "Grand *^12"
.MatchWildcards = True
.Wrap = wdFindStop
Do While .Execute
selection.Collapse Direction:=wdCollapseEnd
lngEnd = selection.End
' Copy the "section"
docOld.Range(lngStart, lngEnd - 1).Copy
'Create a new document to paste text from clipboard.
Set docNew = Documents.Add
selection.Paste
lngDocNum = lngDocNum + 1
sText = docNew.Frames(8).Range.Text
sDirectory = "C:\Users\User\Desktop\Thirdparty Payments\Thirdparty Letters"
Dim Sctn As Section, Frm As Frame, x As Long, v As Single
With ActiveDocument
For Each Sctn In .Sections
With Sctn.Range
v = 0
For x = 1 To .Frames.Count
With .Frames(x)
If .Range.Text = "Grand Total" Then
v = .VerticalPosition - 7.25: Exit For
End If
End With
Next
For x = 1 To .Frames.Count
With .Frames(x)
If .VerticalPosition = v Then sTotal = .Range.Text: Exit For
End With
Next
End With
Next
End With
'sTotal = docNew.Frames(21).Range.Text
Set xlRng = xlWsh.Range("B:B").Find(What:=sText, LookAt:=1, MatchCase:=False)
''Debug.Print "Third party code was not found''
sText2 = docNew.Frames(10).Range.Text
If xlRng Is Nothing Then
MsgBox "THIRD PARTY CODE :" & sText & " " & sText2 & ", NOT IN EXCEL SHEDULE"
End If
If Not xlRng Is Nothing Then
xlRng.Offset(0, 5).Value = Val(sTotal)
End If
'''Convert to PDF'''
docNew.ExportAsFixedFormat OutputFileName:=sDirectory & Trim(sText) & ".pdf", ExportFormat:=17
docNew.Close SaveChanges:=False ''close the new document'''
' set new start
lngStart = lngEnd + 1
Loop
End With
' Last part
selection.Collapse Direction:=wdCollapseEnd
lngEnd = ActiveDocument.Content.End
' Copy the "section"
docOld.Range(lngStart, lngEnd - 1).Copy
'Create a new document to paste text from clipboard.
Set docNew = Documents.Add
selection.Paste
' Save the new document
lngDocNum = lngDocNum + 1
'''Convert to PDF'''
sText = docNew.Frames(8).Range.Text
With ActiveDocument
For Each Sctn In .Sections
With Sctn.Range
v = 0
For x = 1 To .Frames.Count
With .Frames(x)
If .Range.Text = "Grand Total" Then
v = .VerticalPosition - 7.25: Exit For
End If
End With
Next
For x = 1 To .Frames.Count
With .Frames(x)
If .VerticalPosition = v Then sTotal = .Range.Text: Exit For
End With
Next
End With
Next
End With
'sTotal = docNew.Frames(21).Range.Text
Set xlRng = xlWsh.Range("B:B").Find(What:=sText, LookAt:=1, MatchCase:=False)
''Debug.Print "Third party code was not found.",,
sText2 = docNew.Frames(10).Range.Text
If xlRng Is Nothing Then
MsgBox "THIRD PARTY CODE :" & sText & " " & sText2 & ", NOT IN EXCEL SHEDULE"
End If
If Not xlRng Is Nothing Then
xlRng.Offset(0, 5).Value = Val(sTotal)
End If
docNew.ExportAsFixedFormat OutputFileName:=sDirectory & Trim(sText) & ".pdf", ExportFormat:=17
docNew.Close SaveChanges:=False ''close the new document'''
xlWbk.Close SaveChanges:=True
End Sub
I have attached 02 files here. Please help me.
Thanks,
Priyantha.
|