PDA

View Full Version : Replace Multiple Carriage Returns with Single Carriage Returns



swaggerbox
07-19-2016, 02:50 AM
I need to remove multiple carriage returns in all text files in a directory. How do I format this macro so I can use this in Excel?




Sub RemoveConsecutiveBlankLines()


Dim ParagraphCount As Long
Dim Doc As Document
Dim rng As Range
Dim x


Set Doc = ActiveDocument
Set rng = Doc.Range
ParagraphCount = Doc.Paragraphs.Count


'Loop Through Each Paragraph (in reverse order)
For x = ParagraphCount To 1 Step -1
If x - 1 > 1 Then
If rng.Paragraphs(x).Range.Text = vbCr And rng.Paragraphs(x - 1).Range.Text = vbCr Then
rng.Paragraphs(x).Range.Delete
End If
End If
Next x


End Sub

snb
07-19-2016, 02:59 AM
Have you ever read something about VBA ?

swaggerbox
07-19-2016, 03:06 AM
only a bit

Kenneth Hobs
07-19-2016, 05:24 AM
That is MSWord VBA. This is Excel VBA forum. Are you wanting to run the macro from MSWord or Excel? That makes a big difference.

swaggerbox
07-19-2016, 05:31 AM
Yes, if that's possible. Convert from MS Word macro to MS Excel macro. Basically, I need to replace multiple hard returns with single hard returns in text files.

Kenneth Hobs
07-19-2016, 05:50 AM
Well the point is, is there a reason to do it in Excel versus MSWord. If I did it in Excel, I would skip MSWord methods.

By carriage return, I think you mean vbCrLf and not vbCr?

swaggerbox
07-19-2016, 05:52 AM
Aren't they the same thing? Yes maybe vbCrLf, if you can show me some method

swaggerbox
07-19-2016, 05:56 AM
Example format of text file below. There should only be 1 hard return separating <XXML1>***x and <XML1>yyyy, so if there is more than 1 hard return, it should be removed.

<XML1>***x
<AAA>aaa
<BBB>bbb
<XXML1>***x

<XML1>yyyy
<AAA>aaa
<BBB>bbb
<XXML1>yyyy

Kenneth Hobs
07-19-2016, 09:49 AM
Change "X:\FileReadWrite\txt\*.txt" to suit.


Sub Main() Dim a() As Variant, v As Variant, s As String
a() = aFFs("X:\FileReadWrite\txt\*.txt")
'MsgBox Join(a, vbLf)
For Each v In a
s = StrFromTXTFile(CStr(v))
StrToTXTFile CStr(v), Replace(s, vbCrLf & vbCrLf, vbCrLf)
Next v
End Sub




'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
Optional tfSubFolders As Boolean = False) As Variant

Dim s As String, a() As String, v As Variant
Dim b() As Variant, i As Long

If tfSubFolders Then
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
Else
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
End If

a() = Split(s, vbCrLf)
If UBound(a) = -1 Then
MsgBox myDir & " not found.", vbCritical, "Macro Ending"
Exit Function
End If
ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr

For i = 0 To UBound(a)
If Not tfSubFolders Then
s = Left$(myDir, InStrRev(myDir, "\"))
'add the folder name
a(i) = s & a(i)
End If
Next i
aFFs = sA1dtovA1d(a)
End Function


Function sA1dtovA1d(strArray() As String) As Variant
Dim varArray() As Variant, i As Long
ReDim varArray(LBound(strArray) To UBound(strArray))
For i = LBound(strArray) To UBound(strArray)
varArray(i) = CVar(strArray(i))
Next i
sA1dtovA1d = varArray()
End Function


Function StrFromTXTFile(filePath As String) As String
Dim str As String, hFile As Integer

If Dir(filePath) = "" Then
StrFromTXTFile = "NA"
Exit Function
End If

hFile = FreeFile
Open filePath For Binary Access Read As #hFile
str = Input(LOF(hFile), hFile)
Close hFile

StrFromTXTFile = str
End Function


Sub StrToTXTFile(filePath As String, str As String)
Dim hFile As Integer
If Dir(FolderPart(filePath), vbDirectory) = "" Then
MsgBox filePath, vbCritical, "Missing Folder"
Exit Sub
End If

hFile = FreeFile
Open filePath For Output As #hFile
If str <> "" Then Print #hFile, str
Close hFile
End Sub


Function FolderPart(sPath As String) As String
FolderPart = Left(sPath, InStrRev(sPath, "\"))
End Function

swaggerbox
07-20-2016, 12:28 AM
Thanks Ken!