#1
|
|||
|
|||
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 |
#2
|
|||
|
|||
Hi
please help for this issue |
#3
|
||||
|
||||
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 |
#4
|
|||
|
|||
Thanks for the reply Andrew.
I have attached same issue document for the reference . could you please go through attached document. Regards, |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
vba code in word to delete line having inline shape | anand | Word VBA | 7 | 06-18-2015 10:02 PM |
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 |
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 |
Word VBA: Cannot Edit Range (Delete characters except the first in a table cell) | tinfanide | Word VBA | 3 | 04-27-2012 09:48 AM |