Страницы: 1
RSS
Сохранение файла в создаваемую новую папку что будет находиться в родительской папке файла импорта и с названием от импортируемого файла.
 
Здравствуйте

Как используя код VBA сохранить файл после выполнения импорта данных с указанного пользователем файла в папку которая являеться родительской для папки
в которой находиться файл для импорта данных (D:\TestTableQuery\testfile.csv- путь к файлу что содержит данные для импорта; D:\TestTableQuery\ - этот путь изменяеться(динамичен))    
там создать новую папку с названием Import1 и в нее сохранить файл excel с именем которое будет состоять из названия файла что выбирался пользователем для импорта и слов ExcelCore,
тоесть его название должно быть в данном случае testfileExcelCore, а путь сохранения  D:\Import1\testfileExcelCore.xlsx ?
Код
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
Изменено: vikttur - 22.09.2021 19:18:23
 
Здравствуйте
Как то так
Код
ActiveWorkbook.SaveAs FileName:=ActiveWorkbook.path &"\Import1\" & ActiveSheet.Name & "ExcelCore.xlsx"


ps не учтено, что нужно в родительскую вернуться, т.е.  ActiveWorkbook.path обрезать до последнего слэша, но это сами как нибудь
Изменено: bigorq - 22.09.2021 15:36:55
 
Получаю вот такую ошибку и файл не сохраняет
 
Изменено: vikttur - 22.09.2021 19:19:02
 
может файл с таким именем вы сами создали накануне и он все еще открыт в Excel
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, нету аналогичного файла и папки новой тоже нету в которой он бы был

Мой код , если я правильно понимаю ActiveWorkbook.path воспринимает как Default , а попытавшись проверить что же в ActiveWorkbook.path через MsgBox(ActiveWorkbook.path) , то вижу следующее:
Изменено: vikttur - 22.09.2021 19:20:15
 
Ну тогда пойдем другим путем
Код
If Dir(Left(filePathCSV, InStr(filePathCSV, "\")) & "Import1\", vbDirectory) = "" Then
          MkDir Left(filePathCSV, InStr(filePathCSV, "\")) & "Import1\"
 End If
     ActiveWorkbook.SaveAs FileName:= Left(filePathCSV, InStr(filePathCSV, "\")) & "Import1\" & Replace(Mid(filePathCSV, InStrRev(filePathCSV, "\") + 1), ".csv", "ExcelCover.xlsx")

Это если у Вас вложенность небольшая (Папка для импорта в корне диска)
 
bigorq, СПАСИБО - РАБОТАЕТ КАК НАДО
Страницы: 1
Наверх