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 |
.
)