Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 07-14-2016, 08:56 AM
jarunsona jarunsona is offline Want to delete balnk line row  from table with MS word using VBA code Windows 7 32bit Want to delete balnk line row  from table with MS word using VBA code Office 2013
Novice
Want to delete balnk line row  from table with MS word using VBA code
 
Join Date: Jul 2016
Posts: 4
jarunsona is on a distinguished road
Default Want to delete balnk line row from table with MS word using VBA code

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:ESTOCS" & mFile & "'" 'Mid(mFile, 1, Len(Trim(mFile)) - 3) & "DOC"
' mFile = "C:ESTOCS" & 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
Attached Files
File Type: docx Template issue.docx (94.5 KB, 9 views)
Reply With Quote
  #2  
Old 07-20-2016, 07:21 AM
jarunsona jarunsona is offline Want to delete balnk line row  from table with MS word using VBA code Windows 7 32bit Want to delete balnk line row  from table with MS word using VBA code Office 2013
Novice
Want to delete balnk line row  from table with MS word using VBA code
 
Join Date: Jul 2016
Posts: 4
jarunsona is on a distinguished road
Default

Hi

please help for this issue
Reply With Quote
  #3  
Old 07-20-2016, 06:04 PM
Guessed's Avatar
Guessed Guessed is offline Want to delete balnk line row  from table with MS word using VBA code Windows 10 Want to delete balnk line row  from table with MS word using VBA code Office 2013
Expert
 
Join Date: Mar 2010
Location: Canberra/Melbourne Australia
Posts: 3,932
Guessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant future
Default

If you want help on the issue you need to make it easy for someone to spot and solve the issue. You've posted masses of unformatted irrelevant code along with the important code and haven't adequately explained your problem. You haven't provided the mailmerge source nor the word merge document so we would need to recreate those from scratch just to test the code and debug it.

I realise that English may not be your native tongue but you still need to help us actually understand the problem before anyone can step in to assist.

If you want to solve it, look at the lines which insert a row or populate the row. If you step through the code you should be able to spot the problem pretty quickly. We simply can't do that because we don't have the necessary inputs to allow us to run the code.
__________________
Andrew Lockton
Chrysalis Design, Melbourne Australia
Reply With Quote
  #4  
Old 07-21-2016, 04:54 AM
jarunsona jarunsona is offline Want to delete balnk line row  from table with MS word using VBA code Windows 7 32bit Want to delete balnk line row  from table with MS word using VBA code Office 2013
Novice
Want to delete balnk line row  from table with MS word using VBA code
 
Join Date: Jul 2016
Posts: 4
jarunsona is on a distinguished road
Default

Thanks for the reply Andrew.

I have attached same issue document for the reference . could you please go through attached document.

Regards,
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Want to delete balnk line row  from table with MS word using VBA code vba code in word to delete line having inline shape anand Word VBA 7 06-18-2015 10:02 PM
Want to delete balnk line row  from table with MS word using VBA code How to delete the two non-adjacent rows in a table Word beginner Word 2 01-05-2015 05:47 AM
Creating VBA Code to Delete Empty Column in Table Faugs Word VBA 5 08-07-2014 03:29 PM
Want to delete balnk line row  from table with MS word using VBA code VBA Code to take data from a table in word document and place it in a summary table VBLearner Word VBA 1 03-09-2014 08:42 PM
Want to delete balnk line row  from table with MS word using VBA code Word VBA: Cannot Edit Range (Delete characters except the first in a table cell) tinfanide Word VBA 3 04-27-2012 09:48 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 05:50 PM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft