Find and Replace any characters in a list of characters

[Davavo]

Hi,
i could really use some help with this.

i have this code that checks a column for an illegal character (for sheet name) and replaces it with "_".
I want it to check for the fill list of characters that are not allowable sheet names

 .Pattern = "[\<\>\*\\\/\?|]"

Sub ReplaceIllegalCharacters()    'this code searches column "I" for "\" and replaces it with "_"

    Columns("I").Replace What:="\", _
                            Replacement:="_", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False
End Sub

Additionally, since the script is already going through the same column to check for blanks and delete empty rows, i thought it would be most efficient to combine it with this other function...

'This code looks at column I for blanks and deletes the entire row were it finds them.

For j = Cells(Rows.Count, "I").End(xlUp).Row To 1 Step -1    On Error Resume Next
    
    If Cells(j, "I") = "" Then Cells(j, "I").EntireRow.Delete xlUp
    Next j

Thanks for any help

 

[Fluff]

You could use

Function ValidWBName(Arg As String) As String
' Andrew Poulsom
    Dim RegEx As Object
    Set RegEx = CreateObject("VBScript.RegExp")
    With RegEx
        .Pattern = "[\\/:\*\?""<>\|]"
        .Global = True
        ValidWBName = .Replace(Arg, "_")
    End With
End Function

& called like

Sub Davavo()
   Dim Fname As String
   
   Fname = "Abc\de/fg|hi<jk>"
   Fname = ValidWBName(Fname)
End Sub

 

[Davavo]

so, combining the two scripts, this works .... but only searches for one character.

How do I search for the array?

Can anyone help with the syntax, if that is what is required, or how to integrate a loop of some kind?

Thanks

 For j = Cells(Rows.Count, "I").End(xlUp).Row To 1 Step -1    On Error Resume Next
    
    If Cells(j, "I") <> "" Then
    
    Cells(j, "I").Replace What:="/", _
                            Replacement:="_", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False
    
    Else
    
    Cells(j, "I").EntireRow.Delete xlUp
    End If
    
    
    Next j

 

[Davavo]

hello again fluff.
Thanks for your response. I must have been writing my own at the time.
I think i saw that script. It may have been where i copied the list from. But i dont really understand it.
Is that just for one cell? So i should call it repeatedly within a loop for the range?

Like

[COLOR=#333333] For j = Cells(Rows.Count, "I").End(xlUp).Row To 1 Step -1    On Error Resume Next[/COLOR]    
    If Cells(j, "I") <> "" Then

Call Davavo
  
    Else
    
    Cells(j, "I").EntireRow.Delete xlUp
    End If
    
     [COLOR=#333333]    Next j[/COLOR]

 

[Fluff]

Depends on what you are trying to do.
You said

I want it to check for the fill list of characters that are not allowable sheet names

So I assumed that you were creating new sheets, if so can you post your entire code.

 

[Davavo]

Depends on what you are trying to do.
You saidSo I assumed that you were creating new sheets, if so can you post your entire code.

New sheets will be created from this data. I figured this should be part of the import script.

Sub InvoiceReadMacro()

  Dim wb As Workbook
  Dim tw As Workbook
  Dim ws As Worksheet
  Dim Trgtws As Worksheet, myFile
  Dim ob As ListObject
  Dim Lrow1 As Long
  Dim Usdrws As Long
  Dim LastRow As Long
  Dim Testcell As Range
  Dim INVRead As Worksheet
  Dim j As Long
  Dim CheckHeader As Range
  
  Set tw = ThisWorkbook
  Set Trgtws = tw.Sheets("INVRead")
  Set Testcell = Trgtws.Cells(3, 9)
  
  Sheets("INVRead").Unprotect password:="****"
  Sheets("INVRead").Visible = True
   
' Turn off hogs
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
  
Trgtws.Range("A2:N2").Select
With Trgtws.ListObjects("TINVRead")
               .ShowTotals = False
End With




Selection.Font.Color = vbBlack
Range("A2:N2").Font.Bold = False
Application.CutCopyMode = False


  'open workbook
  myFile = Application.GetOpenFilename(, , "Browse for Workbook")
  
  If myFile = False Then
  MsgBox "No File Selected, Cannot continue"
  Exit Sub
  End If
  
  
  With Workbooks.Open(myFile)
  
  Set wb = Workbooks.Open(FileName:=myFile, ReadOnly:=False)
  
   
For Each ws In wb.Worksheets


Set CheckHeader = ws.Range("I1")


If InStr(CheckHeader.Value, "Invoice Type") = 1 Then
    
    On Error Resume Next
    Columns.EntireColumn.Hidden = False
    Rows.EntireRow.Hidden = False
    
If ws.Visible = True Then
    ws.Activate
    ActiveWindow.FreezePanes = False
End If
    
    ActiveSheet.Cells.ClearFormats
       
    '-----------------------------------------------------------------------------------------------------------------------------------------starts here
        
    For j = Cells(Rows.Count, "I").End(xlUp).Row To 1 Step -1
    On Error Resume Next
    
    If Cells(j, "I") <> "" Then
    
    Cells(j, "I").Replace What:="/", _
                            Replacement:="_", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False
    
    Else
    
    Cells(j, "I").EntireRow.Delete xlUp
    End If
    
    
    Next j
        
    '----------------------------------------------------------------------------------------------------------------------------------------end here
    
    LastRow = Trgtws.Cells(Rows.Count, 1).End(xlUp).Row
    Usdrws = ws.Range("I" & Rows.Count).End(xlUp).Row
    
    ws.Range("A2:N" & Usdrws).Copy


If Testcell <> "" Then




    Trgtws.Range("A" & LastRow).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
   
Else
   
    
    Trgtws.Range("A2").PasteSpecial Paste:=xlPasteValues
    Set ob = Trgtws.ListObjects("TINVRead")
    ob.ListRows.Add 1
    
    
End If


End If


Next ws


    
    Application.CutCopyMode = False
    

    
    'make column A weekbegining.
    
Dim r As Long


For r = Trgtws.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
    Trgtws.Range("A" & r).Value = Trgtws.Range("B" & r).Value - Weekday((Trgtws.Range("B" & r).Value), vbUseSystem) + 1
Next r


Trgtws.Range("A2").ClearContents
'------------------------------------------------------------
      
    
    ActiveWorkbook.Close False
    
    Trgtws.Activate
    Range("A1").Select
    
    'get the subtotals




With Trgtws.ListObjects("TINVRead")
               
               .ShowTotals = True
               .ListColumns("VAT Amount").TotalsCalculation = xlTotalsCalculationSum
               .ListColumns("Total Invoice Value").TotalsCalculation = xlTotalsCalculationSum
               .ListColumns("Invoice Value Net").TotalsCalculation = xlTotalsCalculationSum
               .ListColumns("Invoice Type").TotalsCalculation = xlTotalsCalculationCount
               .ListColumns("Task").TotalsCalculation = xlTotalsCalculationCount
               .ListColumns("Comments").TotalsCalculation = xlTotalsCalculationNone
End With
   
    
    
ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
   
     
    Sheets("INVRead").Protect password:="****", _
    UserInterfaceOnly:=True
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFiltering:=True
    
    End With
  MsgBox "Input Complete"
End Sub

 

[Fluff]

I cannot see anything in that code that is creating new sheets.

 

[Davavo]

Sorry for the confusion.

This is not the script that creates new sheets, it is the script that imports the data. If the data in column "I" is cleaned of characters that are not allowed in new sheets, then my script for creating new sheets will work. So thats why i wanted to put the function to replace illegal characters in there.
This is the script that creates new sheets.

Option Explicit

Const sname As String = "INVRead" 'change to whatever starting sheet
Const s As String = "I" 'change to whatever criterion column




Sub columntosheetsINV()


Dim wb As Workbook
Dim sh As Worksheet




Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set wb = ThisWorkbook
Set d = CreateObject("scripting.dictionary")


With wb.Sheets(sname)
    rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    cc = .Columns(s).Column
End With


For Each sh In Worksheets
    d(sh.Name) = 1
Next sh


Application.ScreenUpdating = False
With wb.Sheets.Add(after:=wb.Sheets(sname))
wb.Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
    If a(i, 1) <> a(p, 1) Then
        If d(a(p, 1)) <> 1 Then
            Sheets.Add.Name = a(p, 1)
            .Cells(1).Resize(, cls).Copy Cells(1)
            .Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
        End If
        p = i
    End If
Next i
Application.DisplayAlerts = False
    .Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
wb.Sheets(sname).Activate


End Sub

I have no idea how it works. But it works.

 

[Fluff]

Copy the function from post#2 to a module & then change this line

Sheets.Add.Name = a(p, 1)

to

   Sheets.Add.Name = ValidWBName(a(p, 1))

That way you don't need to change the values in the sheet.

 

[Davavo]

i can just do it this way ....

i just thought there would be a sytax for an array or list

'-----------------------------------------------------------------------------------------------------------------------------------------starts here        
    For j = Cells(Rows.Count, "I").End(xlUp).Row To 1 Step -1
    On Error Resume Next
    
    If Cells(j, "I") <> "" Then
    
    Cells(j, "I").Replace What:="/", _
                            Replacement:="_", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False
    Cells(j, "I").Replace What:="\", _
                            Replacement:="_", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False
    Cells(j, "I").Replace What:=",", _
                            Replacement:="_", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False
    Cells(j, "I").Replace What:=".", _
                            Replacement:="_", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False
    Cells(j, "I").Replace What:=":", _
                            Replacement:="_", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False
    Cells(j, "I").Replace What:=";", _
                            Replacement:="_", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False
    Else
    
    Cells(j, "I").EntireRow.Delete xlUp
    End If
    
    
    Next j
        
    '----------------------------------------------------------------------------------------------------------------------------------------end here