Получить имя активного файла Excel и создать копию

@The_Fog · Регистрация: 24.02.2016

Author24 — интернет-сервис помощи студентам

Скрипт должен получить имя активного файла, создать его копию, и в копии имени заменить некоторые символы.
Например файл назывался "12File_Name.xlsm" нужно создать копию с именем "!55File_Name.xlsm". Подскажите как реализовать такую замену символов в имени.

Visual Basic

Sub Create_xls()
Sheets(1).Copy
With ActiveWorkbook
With .Sheets(1)
.Rows("11:" & .Rows.Count).Delete
.Columns("E:IV").Delete
End With
.SaveAs Filename:=ThisWorkbook.Path & "\!55" & "ThisWorkbook.Name"
.Close True
End With
End Sub

т.е. проблема со строчкой

Visual Basic

1	.SaveAs Filename:=ThisWorkbook.Path & "\!55" & "ThisWorkbook.Name"

Добавлено через 28 минут
Вот нашел на форуме такое решение

Visual Basic

1	.SaveAs Filename:=ThisWorkbook.Path & "\!" & Replace(ActiveDocument.Name, "23", "55")

Но пишет ошибку Run-time error '424' Object required.

=(

toiai · 30.01.2017, 13:58

Сообщение от The_Fog

Replace(ActiveDocument.Name

А причем здесь ActiveDocument?

@The_Fog · 30.01.2017, 14:15 **[ТС]**

Я так понял

PureBasic

1	ActiveDocument.Name

с помощью этой функции можно получить имя файла. Если нет подскажите пожалуйста как получить это имя и заменить в нем пару символов.

toiai · 30.01.2017, 14:19

Сообщение от The_Fog

ActiveDocument.Name

Это Word документ...
может так

Visual Basic

1	ThisWorkbook.Name

@The_Fog · 30.01.2017, 14:37 **[ТС]**

Visual Basic

1	ThisWorkbook.Name

Не не не, я тоже думал что так, но не так =(

Тоже выдает ошибку =(

@Hugo121 · 30.01.2017, 14:40

ThisWorkbook - это не активная книга, а книга с кодом, не факт что они совпадают!

@The_Fog · 30.01.2017, 15:22 **[ТС]**

обе функции ошибку выдают

Visual Basic

1	.SaveAs Filename:=ThisWorkbook.Path & "\!" & Replace(ActiveDocument.Name, "23", "55")

@CyberHelp · 30.01.2017, 15:27

Visual Basic

Public Sub Fog()
Dim Fog1, Fog2 As String
Fog1 = ActiveWorkbook.Name
Fog2 = ActiveWorkbook.Path
ActiveWorkbook.SaveAs Filename:=Fog2 + "\!55" + Fog1
End Sub

Этот макрос скопирует вам активный файл excel в ту же директорию, где находится активный файл, при этом активный файл (например "файл1") будет закрыт и будет открыто окно сохраненного файла (например "!55файл1").

Если вам необходимо, чтобы копия файла сохранялась отдельно, т.е. без закрытия оригинального файла, то немного другой код будет.

@The_Fog · 30.01.2017, 16:53 **[ТС]**

не получается ошибка...

@CyberHelp · 30.01.2017, 17:30

1) Скиньте скриншот.
2) Вы код куда сохранили код макросов? В личную книгу макросов PERSONAL.XLSB?

У меня всё отлично работает.

@CyberHelp · 30.01.2017, 17:37

Вот вложил файл. Зайдите и нажмите на кнопку.
К кнопке привязан код.

@pashulka · 30.01.2017, 18:13

The_Fog, Если проблема только в имени нового файла, то :

Visual Basic

Private Sub Test()
    Worksheets(1).Copy
    Rows("11:" & Rows.Count).Delete
    Columns("E:" & Columns.Count).Delete
    ActiveWorkbook.Close True, Replace(ThisWorkbook.FullName, "12", "!55")
End Sub

@The_Fog · 31.01.2017, 12:51 **[ТС]**

Visual Basic

Public Sub Fog()
Dim Fog1, Fog2 As String
Fog1 = ActiveWorkbook.Name
Fog2 = ActiveWorkbook.Path
ActiveWorkbook.SaveAs Filename:=Fog2 + "\!55" + Fog1
End Sub

Этот макрос скопирует вам активный файл excel в ту же директорию, где находится активный файл, при этом активный файл (например "файл1") будет закрыт и будет открыто окно сохраненного файла (например "!55файл1").

Если вам необходимо, чтобы копия файла сохранялась отдельно, т.е. без закрытия оригинального файла, то немного другой код будет.

Ваш код работает, а у меня почему то нет

Visual Basic

Sub Create_xls()
Dim Fog1, Fog2 As String
 Fog1 = ActiveWorkbook.Name
Fog2 = Replace(Fog1, "ÆÄÓ", "ÝèÔ")
Sheets(1).Copy
With ActiveWorkbook
With .Sheets(1)
.Rows("11:" & .Rows.Count).Delete
.Columns("E:IV").Delete
End With
'ActiveWorkbook.Close True, Replace(ThisWorkbook.FullName, "ÆÄÓ.xlsm", "ÝèÔ.xlsm")
 
'.SaveAs Filename:=ThisWorkbook.Path & "\!" & Replace(ThisWorkbook.FullName, "ÆÄÓ", "ÝèÔ")
.SaveAs Filename:=ThisWorkbook.Path & "\!" + "Fog2"
.Close True
End With

@Hugo121 · 31.01.2017, 12:52

The_Fog, что напишет

Visual Basic

1	msgbox ThisWorkbook.FullName

@CyberHelp · 31.01.2017, 17:11

Попробуйте заменить & на + везде

@Hugo121 · 31.01.2017, 17:15

CyberHelp, вообще обычно рекомендуют делать наоборот

@CyberHelp · 31.01.2017, 17:24

Мой код тоже не работал пока я & не заменил на + :-D

@Hugo121 · 31.01.2017, 17:26

Это интересно, не слышал о таком казусе. Это на какой системе такое?

@The_Fog · 01.02.2017, 17:12 **[ТС]**

Ошибка в моем коде была...
Вот правильный вариант :

Visual Basic

Sub Create_xls()
With ActiveWorkbook
With .Sheets(1)
.Rows("150:" & .Rows.Count).Delete
.Columns("Q:IV").Delete
End With
 
.SaveAs Filename:=.Path & "\!" & Replace(.Name, "ЖДУ.xlsm", "ЭиФ.xlsm")

@CyberHelp 6 / 6 / 1 Регистрация: 29.01.2017 Сообщений: 29
	30.01.2017, 17:30	10
	1) Скиньте скриншот. 2) Вы код куда сохранили код макросов? В личную книгу макросов PERSONAL.XLSB? У меня всё отлично работает. 0

toiai 3218 / 967 / 223 Регистрация: 29.05.2010 Сообщений: 2,087
	30.01.2017, 13:58	2
	Сообщение от The_Fog Replace(ActiveDocument.Name А причем здесь ActiveDocument? 0

@Hugo121 6930 / 2838 / 545 Регистрация: 19.10.2012 Сообщений: 8,670
	30.01.2017, 14:40	6
	ThisWorkbook - это не активная книга, а книга с кодом, не факт что они совпадают! 0

@The_Fog 0 / 0 / 2 Регистрация: 24.02.2016 Сообщений: 75
	30.01.2017, 16:53 [ТС]	9
	не получается ошибка... 0

@CyberHelp 6 / 6 / 1 Регистрация: 29.01.2017 Сообщений: 29
	31.01.2017, 17:11	15
	Попробуйте заменить & на + везде 0

@Hugo121 6930 / 2838 / 545 Регистрация: 19.10.2012 Сообщений: 8,670
	31.01.2017, 17:15	16
	CyberHelp, вообще обычно рекомендуют делать наоборот 0

@CyberHelp 6 / 6 / 1 Регистрация: 29.01.2017 Сообщений: 29
	31.01.2017, 17:24	17
	Мой код тоже не работал пока я & не заменил на + :-D 0

@Hugo121 6930 / 2838 / 545 Регистрация: 19.10.2012 Сообщений: 8,670
	31.01.2017, 17:26	18
	Это интересно, не слышал о таком казусе. Это на какой системе такое? 0