ActiveSheet.Cells.SpecialCells(xlTextValues).Select

 For Each Cell In Selection 
Next

Sub PlanetaExcel()
' Make "D" the current drive:
    ChDrive "D"

'смена текущего каталога на :
    ChDir "D:\TestTableQuery"

' Создание нового листа
    Workbooks.Add

   'Переменная пути к импортируемому файлу:
    Dim filePathCSV

'Рабочий код Вызова диалогового для пользовательского выбора файла и возврата значения для переменной
filePathCSV = Application.GetOpenFilename("CSV files(*.csv),*.csv", 1, "Выбрать файл CSV", , False)

' Условие проверки выбран ли файл и если не выбран то выполняеться команда выхода из процедуры:
If VarType(filePathCSV) = vbBoolean Then
    Exit Sub
End If

' Создание объекта - таблица запроса - импорт с файла данных для

With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & filePathCSV, Destination:=Range("$A$1"))
        .Name = "testfile.csv"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 65001
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With

       ' Do not display the message about overwriting the existing file.
       Application.DisplayAlerts = False

'Количество всех символов
Dim AllCharacters As Long
AllCharacters = Len(filePathCSV)

'Количество всех символов без слеша
Dim AllCharWithOutSlash As Long
AllCharWithOutSlash = Len(Replace(filePathCSV, "\", ""))

'Количество слешей в пути - что тоже что и последний слеш
Dim NSlashs As Long
NSlashs = AllCharacters - AllCharWithOutSlash

'Номер слеша с лева на право который будет третим с правой стороны , что определяет родительскую папку
Dim NSlashL As Long

If NSlashs > 2 Then
NSlashL = NSlashs - 2
ElseIf NSlashs = 2 Then
NSlashL = 2
ElseIf NSlashs = 1 Then
NSlashL = 1
End If

' Позиция (предпоследнего)слеша родительской папки импортируемого файла:
Dim NPosition As Long
NPosition = InStr(Application.WorksheetFunction.Substitute(filePathCSV, "\", "^", NSlashL), "^")

' Позиция последнего слеша в пути к файлу :
Dim NPositionEnd As Long
NPositionEnd = InStr(Application.WorksheetFunction.Substitute(filePathCSV, "\", "^", NSlashs), "^")
'******************************************************************
'Создание файла ExcelCore:
'Проверка на наличие папки с одинаковым именем и если нету одноименной папки, то создаеться новая папка TestExcel:
If Dir(Left(filePathCSV, NPosition) & "TestExcel\", vbDirectory) = "" Then
          MkDir Left(filePathCSV, NPosition) & "TestExcel\"
          End If

   'Сохранение файла с нужным именем в нужную папку
ActiveWorkbook.SaveAs FileName:=Left(filePathCSV, NPosition) & "TestExcel\" & Replace(Mid(filePathCSV, NPositionEnd + 1), ".csv", "ExcelCore.xlsx")

   'Альтернативный код : Close the workbook by using the following.
       ActiveWorkbook.Close
'******************************************************************
' Открытие ExcelCore; запуск макроса по подготовке с ExcelCore csv файла для Folder1

   Workbooks.Open FileName:= _
        Left(filePathCSV, NPosition) & "TestExcel\" & Replace(Mid(filePathCSV, NPositionEnd + 1), ".csv", "ExcelCore.xlsx") _
        , Origin:=xlWindows

' Запуск макроса по подготовке с ExcelCore csv файла для Folder1- для теста необязателен::
'    Application.Run "PERSONAL.XLSB!Folder1ForSvg"

    'Проверка на наличие папки с одинаковым именем и если нету одноименной папки, то создаеться новая папка:
If Dir(Left(filePathCSV, NPosition) & "8__________Folder1\", vbDirectory) = "" Then
          MkDir Left(filePathCSV, NPosition) & "8__________Folder1\"
          End If

    ActiveWorkbook.SaveAs FileName:= _
        Left(filePathCSV, NPosition) & "8__________Folder1\" & Replace(Mid(filePathCSV, NPositionEnd + 1), ".csv", "") & "Folder1.csv", FileFormat:= _
        xlCSV, CreateBackup:=False, local:=False

'******************************************************************
' Открытие ExcelCore; запуск макроса по подготовке с ExcelCore csv файла для Folder2

   Workbooks.Open FileName:= _
        Left(filePathCSV, NPosition) & "TestExcel\" & Replace(Mid(filePathCSV, NPositionEnd + 1), ".csv", "ExcelCore.xlsx") _
        , Origin:=xlWindows

        'Не работает для исправления ошибки связаной с запятой:
'        , Semicolon:=True
'''        , DataType:=xlDelimited,
'''        Local:=True

' Запуск макроса по подготовке с ExcelCore csv файла для Folder2- для теста необязателен:
'Application.Run "PERSONAL.XLSB!l_____Folder2_prepair_CSV"

'Проверка на наличие папки с одинаковым именем и если нету одноименной папки, то создаеться новая папка:
If Dir(Left(filePathCSV, NPosition) & "4__________Folder2_csv\", vbDirectory) = "" Then
          MkDir Left(filePathCSV, NPosition) & "4__________Folder2_csv\"
          End If

    ActiveWorkbook.SaveAs FileName:= _
        Left(filePathCSV, NPosition) & "4__________Folder2_csv\" & Replace(Mid(filePathCSV, NPositionEnd + 1), ".csv", "") & "Folder2.csv", _
        FileFormat:=xlCSV, _
        CreateBackup:=False, _
        local:=False
'******************************************************************
' Открытие ExcelCore; запуск макроса по подготовке с ExcelCore csv файла для Folder3

   Workbooks.Open FileName:= _
        Left(filePathCSV, NPosition) & "TestExcel\" & Replace(Mid(filePathCSV, NPositionEnd + 1), ".csv", "ExcelCore.xlsx") _
        , Origin:=xlWindows

' Запуск макроса по подготовке с ExcelCore csv файла для Folder3- для теста необязателен::
'    Application.Run "PERSONAL.XLSB!l_____Folder3_prepair_CSV"

    'Проверка на наличие папки с одинаковым именем и если нету одноименной папки, то создаеться новая папка:
If Dir(Left(filePathCSV, NPosition) & "3__________Folder3_csv\", vbDirectory) = "" Then
          MkDir Left(filePathCSV, NPosition) & "3__________Folder3_csv\"
          End If

    ActiveWorkbook.SaveAs FileName:= _
        Left(filePathCSV, NPosition) & "3__________Folder3_csv\" & Replace(Mid(filePathCSV, NPositionEnd + 1), ".csv", "") & "Folder3.csv", FileFormat:= _
        xlCSV, CreateBackup:=False, local:=False
'******************************************************************
' Открытие ExcelCore; запуск макроса по подготовке с ExcelCore csv файла для Folder4
   Workbooks.Open FileName:= _
        Left(filePathCSV, NPosition) & "TestExcel\" & Replace(Mid(filePathCSV, NPositionEnd + 1), ".csv", "ExcelCore.xlsx") _
        , Origin:=xlWindows

' Запуск макроса по подготовке с ExcelCore csv файла для Folder4 - для теста необязателен:
'    Application.Run "PERSONAL.XLSB!l_____Folder4_prepair_CSV"

    'Проверка на наличие папки с одинаковым именем и если нету одноименной папки, то создаеться новая папка:
If Dir(Left(filePathCSV, NPosition) & "6__________Folder4\", vbDirectory) = "" Then
          MkDir Left(filePathCSV, NPosition) & "6__________Folder4\"
          End If

    ActiveWorkbook.SaveAs FileName:= _
        Left(filePathCSV, NPosition) & "6__________Folder4\" & Replace(Mid(filePathCSV, NPositionEnd + 1), ".csv", "") & "Folder4.csv", FileFormat:= _
        xlCSV, CreateBackup:=False, local:=False
' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' VVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV
' Открытые книги при таком коде не закрываються если указан явно адресс для  Notepad или если указан или относительный путь как ниже то Notepad
Application.SendKeys "^w~~"
Application.SendKeys "^w~~"
Application.SendKeys "^w~~"
Application.SendKeys "^w~~"
Application.SendKeys "^w~~"

 Dim res As Variant
    Dim fileToOpen As String
    Dim nppPath As String

    fileToOpen = Left(filePathCSV, NPosition) & "Folder4\" & Replace(Mid(filePathCSV, NPositionEnd + 1), ".csv", "") & "Folder4.csv"
    MsgBox fileToOpen, , "Title file Path"
    nppPath = "C:\Program Files\Notepad++\notepad++.exe"

    res = Shell(nppPath & " " & fileToOpen, vbNormalFocus)

'На этом этапе возникает ошибка Notepad о том что файла не существует хотя в папке смотрю файл есть
' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' VVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV

Application.SendKeys ("%a") ' --- запуск макроса в Notepad++
Application.SendKeys ("^s") ' --- сохранение изменений в открытом файле
Application.SendKeys ("%{F4}") '--- закрытие программы
    
 ' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! всего будет создаваться 4 файла, но для простоты теста пока указываем один
End Sub

Sub TestTableQuary4()

' Make "D" the current drive
    ChDrive "D"

'смена текущего каталога на :
    ChDir "D:\TestTableQuery"

' Создание нового листа
    Workbooks.Add
    
Dim filePathCSV
filePathCSV = Application.GetOpenFilename("CSV files(*.csv),*.csv", 1, "Выбрать файл CSV", , False)

If VarType(filePathCSV) = vbBoolean Then
    Exit Sub
End If

With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & filePathCSV, Destination:=Range("$A$1"))
  
'        .CommandType = 0
        .Name = "testfile.csv"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 65001
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With

       ' Do not display the message about overwriting the existing file.
       Application.DisplayAlerts = False

       'Рабочий старый код:
'       ActiveWorkbook.SaveAs FileName:="D:\TestSave\" & MyFile
 
       ' Тестовый код:
       ActiveWorkbook.SaveAs FileName:="D:\TestSave\ExcelCore"

       ' Close the workbook by using the following.
       ActiveWorkbook.Close
End Sub