View Single Post
 
Old 08-27-2014, 10:47 PM
excelledsoftware excelledsoftware is offline Windows 7 64bit Office 2003
IT Specialist
 
Join Date: Jan 2012
Location: Utah
Posts: 455
excelledsoftware will become famous soon enough
Default

OK I tested this a couple of times and it seems to work fine.

Keep in mind that this will change every single excel file in a folder so make sure to make a backup of the entire folder before running. This will replace the carriage return with a comma in the headers as well. If we need to fix that I will have to find out the exact text in those 2 headers but other than that it appears to work.

Code:
Option Explicit
Dim cwb As Workbook, ws As Worksheet

Sub RemoveAllCarriageReturns()
  'Goes through all files of a specified folder and removes all
  'carriage returns from Columns C and D and replaces them with a comma
  'Saves the workbook with the same name in the folder and moves to the next file.
  
  Dim FolderString As String, StrFile As String, Confirm As String, wb As Workbook
  
    Confirm = MsgBox("This code will replace all carriage returns and line breaks with a comma." & vbLf & _
    "This will be done to every single workbook within the folder that you specify." & vbLf & _
    "It is strongly recommended that you create the necessary backups before running this code." & vbLf & _
    "Do you wish to continue?", vbYesNo)
    
    If Confirm = vbNo Then End
    
  
    Set wb = ThisWorkbook
  
    FolderString = InputBox("Folder Location:")
    If FolderString = "" Then End
    
    
    'Set the file folder
    StrFile = Dir(FolderString & "/")
    
    Do While Len(StrFile) <> 0
      If InStr(1, StrFile, ".xls") <> 0 Or InStr(1, StrFile, ".xlsm") <> 0 Then
        Workbooks.Open Filename:=StrFile
        Set cwb = ActiveWorkbook
        Debug.Print cwb.Name
        Set ws = cwb.Worksheets(1)
        LineBreakReplace
        cwb.Save
        cwb.Close
      End If
      Set cwb = Nothing
      Set ws = Nothing
      StrFile = Dir()
    Loop
    
    MsgBox ("Complete")

End Sub




Function LineBreakReplace()
  Dim CTotalRows As Long, DTotalRows As Long, TotalRows As Long, x As Byte
  Dim CheckRow As Long, CheckString As String, BadData As Variant
  
    'Find the Last Row
    CTotalRows = ws.Range("C50000").End(xlUp).Row
    DTotalRows = ws.Range("D50000").End(xlUp).Row
    If CTotalRows > DTotalRows Then
      TotalRows = CTotalRows
    Else
      TotalRows = DTotalRows
    End If

    On Error GoTo 0 'Reset error handling and enter line breaks in the array
    BadData = Array(vbCr, vbLf, vbCrLf, Chr(10), Chr(13))
    
    'Clean Column C
    For CheckRow = 1 To TotalRows
      CheckString = ws.Range("C" & CheckRow).Value
      For x = 0 To 4
        If InStr(1, CheckString, BadData(x)) Then
          ws.Range("C" & CheckRow).Value = Replace(CheckString, BadData(x), ",")
        End If
      Next x
    Next CheckRow
    
    'Clean Column D
    For CheckRow = 1 To TotalRows
      CheckString = ws.Range("D" & CheckRow).Value
      For x = 0 To 4
        If InStr(1, CheckString, BadData(x)) Then
          ws.Range("D" & CheckRow).Value = _
          WorksheetFunction.Substitute(CheckString, BadData(x), ",")
        End If
      Next x
    Next CheckRow
End Function
Copy and paste the entire code and then run the sub. The function will run automatically when it is called.

Let me know how it works I will be happy to fix anything if there are issues.

Thanks for this opportunity.
Reply With Quote