Private Sub ReplaceSpecialCharacters()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim specialChars As String
Dim replaceChar As String
' Define the worksheet to be processed
Set ws = ThisWorkbook.Worksheets("Sheet1") ' Update "Sheet1" with your sheet name
' Define the range to be processed (assuming data starts from A1)
Set rng = ws.UsedRange
' Define the special characters to be replaced
specialChars = "*?;{}[]|\`'"""
' Define the character to replace special characters with
replaceChar = "_" ' You can change this to whatever character you want
' Loop through each cell in the range
For Each cell In rng
If Not IsEmpty(cell.Value) Then
' Loop through each character in the cell's value
For i = 1 To Len(cell.Value)
' Check if the character is a special character
If InStr(specialChars, Mid(cell.Value, i, 1)) > 0 Then
' Replace the special character with the desired character
cell.Value = Replace(cell.Value, Mid(cell.Value, i, 1), replaceChar)
End If
Next i
End If
Next cell
End Sub
Private Sub Concatenate()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim LastRow As Long
Dim LastCol As Long
Dim i As Long
Dim concatenatedValue As String
Dim Columni As String
Dim j As Long
Dim k As Long
Set SourceRange = Application.Selection
k = 1
' Set the source worksheets
Set wsSource = ThisWorkbook.Sheets("Sheet1")
' Create a new sheet and rename it
On Error Resume Next
Application.DisplayAlerts = False
ActiveWorkbook.Sheets("Sheet2").Delete
On Error GoTo 0
ActiveWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Sheet2"
' Set the target worksheets
Set wsTarget = ThisWorkbook.Sheets("Sheet2")
' Find the last row with data in column A of the source sheet
LastRow = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row
' Loop through each row
For i = 2 To LastRow
LastCol = wsSource.Cells(i, wsSource.Columns.Count).End(xlToLeft).Column
' Initialize concatenatedValue for each row
concatenatedValue = "Reason Tree\"
' adding root elements
If k = 1 Then
wsTarget.Cells(1, 2).Value = "Reason Tree"
wsTarget.Cells(1, 4).Value = "Reason Tree Root"
k = k + 1
End If
wsTarget.Cells(k, 1).Value = concatenatedValue
' Loop through each column in the current row
For j = 2 To LastCol
wsTarget.Cells(k, 1).Value = concatenatedValue
wsTarget.Cells(k, 2).Value = wsSource.Cells(i, j).Value
concatenatedValue = concatenatedValue & wsSource.Cells(i, j).Value & "\"
If j < LastCol Then
wsTarget.Cells(k, 4).Value = "Reason Tree Node"
Else
wsTarget.Cells(k, 4).Value = "Reason Tree Leaf"
wsTarget.Cells(k, 3).Value = "Root Categories\" & wsSource.Cells(i, 1).Value
End If
k = k + 1
Next j
' Remove the trailing "\" from the concatenated value
concatenatedValue = Left(concatenatedValue, Len(concatenatedValue) - 1)
For l = 1 To Step - 1
Set EntireRow = wsTarget.Cells(i, 1).EntireRow
If Application.WorksheetFunction.CountA(EntireRow) = 0 Then
EntureRow.Delete
End If
Next l
Next i
End Sub
Private Sub DeleteBlankRows()
Dim SourceRange As Range
Dim EntireRow As Range
Set SourceRange = Application.Selection
If Not (SourceRange Is Nothing) Then
Application.ScreenUpdating = False
For i = SourceRange.Rows.Count To 1 Step -1
Set EntireRow = SourceRange.Cells(i, 1).EntireRow
If Application.WorksheetFunction.CountA(EntireRow) = 0 Then
EntireRow.Delete
End If
Next
Application.ScreenUpdating = True
End If
End Sub
Private Sub RemoveDuplicates()
Dim B As Long
B = Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:AA" & B).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
End Sub
Sub Run()
Call ReplaceSpecialCharacters
Call Concatenate
Call DeleteBlankRows
Call RemoveDuplicates
End Sub
