Find and Replace any characters in a list of characters

Davavo

Board Regular
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
Code:
 .Pattern = "[\<\>\*\\\/\?|]"
Code:
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...

Code:
'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

MrExcel MVP, Moderator
You could use
Code:
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
Code:
Sub Davavo()
   Dim Fname As String
   
   Fname = "Abc\de/fg|hi<jk>"
   Fname = ValidWBName(Fname)
End Sub
 

Davavo

Board Regular
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

Code:
 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

Board Regular
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
Code:
[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

MrExcel MVP, Moderator
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

Board Regular
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.

Code:
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
 
Last edited:

Fluff

MrExcel MVP, Moderator
I cannot see anything in that code that is creating new sheets.
 

Davavo

Board Regular
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.

Code:
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

MrExcel MVP, Moderator
Copy the function from post#2 to a module & then change this line
Code:
Sheets.Add.Name = a(p, 1)
to
Code:
   Sheets.Add.Name = ValidWBName(a(p, 1))
That way you don't need to change the values in the sheet.
 
Last edited:

Davavo

Board Regular
i can just do it this way ....

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

Code:
'-----------------------------------------------------------------------------------------------------------------------------------------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
 

Some videos you may like

This Week's Hot Topics

  • Importing multiple excel files into one spreadsheet
    Hi, I'm trying to import multiple excel files (with the same format into a single spreadsheet) so that each day's file is listed underneath the...
  • find many based on a certain criteria
    good evening, I hope someone can help me? I have a workbook sheet 2 contains lots of data.... I would like to be able to find anything on sheet...
  • How to copy multiple rows using If
    Hi all, I'm very new to VBA and have written this simple code to copy certain cells if a certain cell within that row contains any data. I need...
  • VBA If statement
    Dear All, I have two dates, where I'd like a message box to pop, if the dates are between this criteria. [CODE] sDate1 = #10/1/2019#...
  • Text Format
    I have a sheet for user to keyin the data. The format of the data can be 451 / 1903, 0012 / 9908 or 00287 / 0099. The number after the "/" is...
  • Macro to copy values across rows and transposing them and add the user id
    [FONT=Times New Roman][SIZE=3][COLOR=#000000][/COLOR][/SIZE][/FONT][FONT=Calibri][SIZE=3][COLOR=#000000]Hi,[/COLOR][/SIZE][/FONT] [FONT=Times New...
Top