Hi All,
ISSUE :
There is one MS word template with VBA code when I run after deleting unwanted columns. it will insert a new blank line in a table. Why it is inserting a new blank line? How to overcome this issue?
PLEASE FIND ATTACHED TEPLATE
Here is VBA code :
Option Explicit
Option Base 0
Sub encabezado()
On Error GoTo branding_error:
Dim fecha As Date
Dim ii As Integer
Dim nombreFichero As String
Dim msg As String
fecha = Now
ii = Second(Now)
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
With Selection.ParagraphFormat
.FirstLineIndent = CentimetersToPoints(0)
.LeftIndent = CentimetersToPoints(0)
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
End With
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
branding_error:
If Err.Number <> 0 Then
msg = "Error al actualizar al nuevo branding "
End If
End Sub
Sub branding()
Application.ScreenUpdating = False
encabezado
Application.ScreenUpdating = True
End Sub
Sub auto_open()
Dim msg, sFile, mFile, sTMSdoc, strLine, s, pth, prm As String
Dim objFileSystem As Object
Dim strFile, fArray, keyArr, fldArr, prmArr, shrArr, flrArr As Variant
Dim i, k1, k2, k3, k4, k5, k6, Fld1, Fld2, Fld3, Fld4, Fld5, Fld6 As Integer
Dim pos, ln As Long
Const Fld1Nam = "T1PUGD"
Const Fld2Nam = "T2CSTYP"
Const Fld3Tst = "T3CSTYP"
Const Fld3Nam = "T3BSI"
Const Fld4Nam = "T4TXT"
Const Fld5Nam = "T5PPRC"
Const Fld6Nam = "T6BIDC"
branding
On Error GoTo tms_error:
#If Mac Then
pth = "Macintosh HD:Applications:IBS:Agent"
s = Application.PathSeparator
prm = pth & s & "TMSprm.txt"
Open prm For Input As #1
Line Input #1, sFile
Close #1
prmArr = SplitM(sFile, Chr(10))
sFile = prmArr(2)
flrArr = SplitM(sFile, "/")
sFile = ""
For i = 3 To UBound(flrArr)
sFile = sFile & s & flrArr(i)
Next i
mFile = prmArr(3)
shrArr = SplitM(mFile, " //")
For i = LBound(shrArr) To UBound(shrArr)
pos = InStr(3, shrArr(i), "/") + 1
ln = InStr(pos, shrArr(i), " ") - pos
shrArr(i) = Mid(shrArr(i), pos, ln) & sFile
'MsgBox shrArr(i)
On Error Resume Next
Open shrArr(i) For Input As #2
On Error GoTo 0
If Err.Number = 0 Then
sFile = shrArr(i)
Close #2
Exit For
End If
Next i
' For i = 1 To Len(sFile)
' If Mid(sFile, i, 1) = Chr(10) Or Mid(sFile, i, 1) = Chr(13) Then
' mFile = s & Mid(sFile, 1, i - 1)
' sFile = pth & mFile
' ' mFile = "'" & "Macintosh HD:Volumes:TMS001;TMS09:EST
OCS" & mFile & "'" 'Mid(mFile, 1, Len(Trim(mFile)) - 3) & "DOC"
' mFile = "C:EST
OCS" & mFile
' Exit For
' End If
' Next
#Else
sFile = GetSetting("TMS", "Parameters", "Parm1", "")
If sFile = "" Then
sFile = GetSetting("TMS", "Parameters", "Parm0", "")
fArray = Split(sFile, " ")
sFile = fArray(1)
End If
#End If
sTMSdoc = ActiveDocument.Path & Application.PathSeparator & ActiveDocument.Name
If sFile <> "" Then
Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone
Open sFile For Input As #1
Line Input #1, strLine
fldArr = SplitM(strLine, ",")
For i = LBound(fldArr) To UBound(fldArr)
Select Case Trim(fldArr(i))
Case Fld1Nam
Fld1 = i
Case Fld2Nam
Fld2 = i
Case Fld3Tst
Fld3 = i
Case Fld4Nam
Fld4 = i
Case Fld5Nam
Fld5 = i
Case Fld6Nam
Fld6 = i
End Select
Next i
Do While Not EOF(1)
Line Input #1, strLine
keyArr = SplitM(strLine, Chr(34) & "," & Chr(34))
keyArr(Fld1) = ReplaceM(keyArr(Fld1), Chr(34), " ")
If Trim(keyArr(Fld1)) <> "" Then
k1 = k1 + 1
End If
keyArr(Fld2) = ReplaceM(keyArr(Fld2), Chr(34), " ")
If Trim(keyArr(Fld2)) <> "" Then
k2 = k2 + 1
End If
keyArr(Fld3) = ReplaceM(keyArr(Fld3), Chr(34), " ")
If Trim(keyArr(Fld3)) <> "" Then
k3 = k3 + 1
End If
keyArr(Fld4) = ReplaceM(keyArr(Fld4), Chr(34), " ")
If Trim(keyArr(Fld4)) <> "" Then
k4 = k4 + 1
End If
keyArr(Fld5) = ReplaceM(keyArr(Fld5), Chr(34), " ")
If Trim(keyArr(Fld5)) <> "" Then
k5 = k5 + 1
End If
keyArr(Fld6) = ReplaceM(keyArr(Fld6), Chr(34), " ")
If Trim(keyArr(Fld6)) <> "" Then
k6 = k6 + 1
End If
Loop
Close #1
If k1 > 1 Then
Call AddRows(k1 - 1, Fld1Nam)
End If
If k2 > 1 Then
Call AddRows(k2 - 1, Fld2Nam)
End If
If k3 > 1 Then
Call AddRows(k3 - 1, Fld3Nam)
End If
If k4 > 1 Then
Call AddRows(k4 - 1, Fld4Nam)
End If
If k5 > 1 Then
Call AddRows(k5 - 1, Fld5Nam)
End If
If k6 > 1 Then
Call AddRows(k6 - 1, Fld6Nam)
End If
With ActiveDocument.MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource Name:=sFile, _
ConfirmConversions:=False, ReadOnly:=True, LinkToSource:=False, _
AddToRecentFiles:=False, Revert:=False, Format:=wdOpenFormatUnicodeText
', SubType:=wdMergeSubTypeOther
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
ActiveDocument.SaveAs FileName:=Mid(sFile, 1, Len(Trim(sFile)) - 3) & "DOC", FileFormat:=wdFormatDocument
'FileCopy Mid(sFile, 1, Len(Trim(sFile)) - 3) & "DOC", mFile
'Kill sFile
Application.ScreenUpdating = True
End If
On Error Resume Next
' DeleteSetting "TMS", "Parameters", "Parm0"
CloseFile (sTMSdoc)
Exit Sub
tms_error:
If Err.Number <> 0 Then
msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox msg, , "Error", Err.HelpFile, Err.HelpContext
End If
End Sub
Sub CloseFile(FileName As String)
Dim P As Document
' Search the open docs for the file.
For Each P In Application.Documents
' If the file is found, close it.
If P.FullName = FileName Then
P.Activate
P.Close wdDoNotSaveChanges
Exit Sub
End If
Next P
End Sub
Sub AddRows(iRep As Integer, sCod As String)
Dim i As Integer
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
.Text = sCod
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
If Selection.Find.Execute Then
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=2, Extend:=wdExtend
Selection.Copy
For i = 1 To iRep
Selection.InsertRowsBelow
Selection.Paste
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"NEXT ", PreserveFormatting:=True
Next
End If
End Sub
Function SplitM(ByVal strIn As String, _
Optional ByVal strDelim As String = " ", _
Optional ByVal lCount As Long = -1) _
As Variant
Dim vOut() As Variant
Dim strSubString As String
Dim k As Integer
Dim lDelimPos As Long
k = 0
lDelimPos = InStr(strIn, strDelim)
Do While (lDelimPos)
' Get everything to the left of the delimiter
strSubString = Left(strIn, lDelimPos - 1)
' Make the return array one element larger
ReDim Preserve vOut(k)
' Add the new element
vOut(k) = strSubString
k = k + 1
If lCount <> -1 And k = lCount Then
SplitM = vOut
Exit Function
End If
' Only interested in what's right of delimiter
strIn = Right(strIn, (Len(strIn) - _
(lDelimPos + Len(strDelim) - 1)))
' See if delimiter occurs again
lDelimPos = InStr(strIn, strDelim)
Loop
' No more delimiters in string.
' Add what's left as last element
ReDim Preserve vOut(k)
vOut(k) = strIn
SplitM = vOut
End Function
Public Function ReplaceM(ByVal sIn As String, ByVal sFind As _
String, ByVal sReplace As String, Optional nStart As _
Long = 1, Optional nCount As Long = -1) As _
String
Dim nC As Long, nPos As Long
Dim nFindLen As Long, nReplaceLen As Long
nFindLen = Len(sFind)
nReplaceLen = Len(sReplace)
If (sFind <> "") And (sFind <> sReplace) Then
nPos = InStr(nStart, sIn, sFind)
Do While nPos
nC = nC + 1
sIn = Left(sIn, nPos - 1) & sReplace & _
Mid(sIn, nPos + nFindLen)
If nCount <> -1 And nC >= nCount Then Exit Do
nPos = InStr(nPos + nReplaceLen, sIn, sFind)
Loop
End If
ReplaceM = sIn
End Function
Regards,
Arun