Доброго времени суток уважаемые форумчане. Задача состоит в том. Чтобы копировать файл в папку с новым именем, но с подменной данных из ячейки. Нашел два макроса: Первый копирует файл с новыми значениями
[vba]
Код
Sub CHANGE_NAME_FILE() Application.ScreenUpdating = 0 Application.DisplayAlerts = 0 Dim Im_Main, Put_File, sch_VERT As Variant Dim FS, KATALOG, FILE, MASSIV As Object Dim II, JJ As Integer Range("C2:C65000").Select Selection.ClearContents sch_VERT = Cells(1, 1).End(xlDown).Row - 1 Dim OLD_NAME(), NEW_NAME() As Variant ReDim OLD_NAME(sch_VERT, 1), NEW_NAME(sch_VERT, 1) Range("A1:B" + Trim(Str(sch_VERT + 1))).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal OLD_NAME = Range(Cells(2, 1), Cells(2 + sch_VERT, 1)) NEW_NAME = Range(Cells(2, 2), Cells(2 + sch_VERT, 2))
Im_Main = ActiveWorkbook.Name Put_File = Application.ActiveWorkbook.Path + "\" Set FS = CreateObject("Scripting.FileSystemObject") Set KATALOG = FS.GetFolder(Put_File) Set MASSIV = KATALOG.Files If Dir(Put_File + "OUT\", vbDirectory) = "" Then MkDir (Put_File + "OUT\") End If If Dir(Put_File + "OUT\", vbDirectory) <> "" Then 'If Len(Dir(Put_File + "OUT\*.*")) > 0 Then 'Kill (Put_File + "OUT\*.*") 'End If
For II = 1 To sch_VERT For Each FILE In MASSIV If Dir(FILE) = OLD_NAME(II, 1) And Dir(FILE) <> Im_Main Then FileCopy FILE, Application.ActiveWorkbook.Path + "\OUT\" + NEW_NAME(II, 1) Cells(II + 1, 5).Value = "готов" End If Next Next 'ii MsgBox "ГОТОВО" End If Application.ScreenUpdating = 1 Application.DisplayAlerts = 1 End Sub
[/vba]
Второй изменяет текст
[vba]
Код
Sub test() Const ForReading = 1 Const TristateFalse = 0 Set FSO = CreateObject("Scripting.FileSystemObject") Filename = "C:\Users\Televnoy\Desktop\обрабатываемые файлы\OUT\m-08 1.txt" Set F = FSO.OpenTextFile(Filename, ForReading, TristateFalse) WorkStrAll = F.ReadAll WorkStrAll = Replace(WorkStrAll, "КОШКА", "ПЕС") Set F = FSO.CreateTextFile(Filename, True) F.Write (WorkStrAll) F.Close End Sub
[/vba]
Хочу последний макрос вклинить в предыдущий, до последней процедуры. Добавил переменные OLD_ID(), NEW_ID путь прописал Filename = Put_File + "OUT\" & NEW_NAME, но как то я все криво понаделал.
[vba]
Код
Sub CHANGE_NAME_FILE() Application.ScreenUpdating = 0 Application.DisplayAlerts = 0 Dim Im_Main, Put_File, sch_VERT As Variant Dim FS, KATALOG, FILE, MASSIV As Object Dim II, JJ As Integer Range("C2:C65000").Select Selection.ClearContents sch_VERT = Cells(1, 1).End(xlDown).Row - 1 Dim OLD_NAME(), NEW_NAME(), OLD_ID(), NEW_ID As Variant ReDim OLD_NAME(sch_VERT, 1), NEW_NAME(sch_VERT, 1) Range("A1:B" + Trim(Str(sch_VERT + 1))).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal OLD_NAME = Range(Cells(2, 1), Cells(2 + sch_VERT, 1)) NEW_NAME = Range(Cells(2, 2), Cells(2 + sch_VERT, 2)) '_____________________________ OLD_ID() = Range(Cells(2, 3), Cells(2 + sch_VERT, 3)) NEW_ID() = Range(Cells(2, 4), Cells(2 + sch_VERT, 4)) '_____________________________ Im_Main = ActiveWorkbook.Name Put_File = Application.ActiveWorkbook.Path + "\" Set FS = CreateObject("Scripting.FileSystemObject") Set KATALOG = FS.GetFolder(Put_File) Set MASSIV = KATALOG.Files If Dir(Put_File + "OUT\", vbDirectory) = "" Then MkDir (Put_File + "OUT\") End If If Dir(Put_File + "OUT\", vbDirectory) <> "" Then 'If Len(Dir(Put_File + "OUT\*.*")) > 0 Then 'Kill (Put_File + "OUT\*.*") 'End If '_____________________________ Const ForReading = 1 Const TristateFalse = 0 Set FSO = CreateObject("Scripting.FileSystemObject") Filename = Put_File + "OUT\" & NEW_NAME Set F = FSO.OpenTextFile(Filename, ForReading, TristateFalse) WorkStrAll = F.ReadAll WorkStrAll = Replace(WorkStrAll, OLD_ID, NEW_ID) Set F = FSO.CreateTextFile(Filename, True) F.Write (WorkStrAll) F.Close '__________________________________
For II = 1 To sch_VERT For Each FILE In MASSIV If Dir(FILE) = OLD_NAME(II, 1) And Dir(FILE) <> Im_Main Then FileCopy FILE, Application.ActiveWorkbook.Path + "\OUT\" + NEW_NAME(II, 1) Cells(II + 1, 5).Value = "готов" End If Next Next 'ii MsgBox "ГОТОВО" End If Application.ScreenUpdating = 1 Application.DisplayAlerts = 1 End Sub
[/vba]
Свои правки выделил '______________
Доброго времени суток уважаемые форумчане. Задача состоит в том. Чтобы копировать файл в папку с новым именем, но с подменной данных из ячейки. Нашел два макроса: Первый копирует файл с новыми значениями
[vba]
Код
Sub CHANGE_NAME_FILE() Application.ScreenUpdating = 0 Application.DisplayAlerts = 0 Dim Im_Main, Put_File, sch_VERT As Variant Dim FS, KATALOG, FILE, MASSIV As Object Dim II, JJ As Integer Range("C2:C65000").Select Selection.ClearContents sch_VERT = Cells(1, 1).End(xlDown).Row - 1 Dim OLD_NAME(), NEW_NAME() As Variant ReDim OLD_NAME(sch_VERT, 1), NEW_NAME(sch_VERT, 1) Range("A1:B" + Trim(Str(sch_VERT + 1))).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal OLD_NAME = Range(Cells(2, 1), Cells(2 + sch_VERT, 1)) NEW_NAME = Range(Cells(2, 2), Cells(2 + sch_VERT, 2))
Im_Main = ActiveWorkbook.Name Put_File = Application.ActiveWorkbook.Path + "\" Set FS = CreateObject("Scripting.FileSystemObject") Set KATALOG = FS.GetFolder(Put_File) Set MASSIV = KATALOG.Files If Dir(Put_File + "OUT\", vbDirectory) = "" Then MkDir (Put_File + "OUT\") End If If Dir(Put_File + "OUT\", vbDirectory) <> "" Then 'If Len(Dir(Put_File + "OUT\*.*")) > 0 Then 'Kill (Put_File + "OUT\*.*") 'End If
For II = 1 To sch_VERT For Each FILE In MASSIV If Dir(FILE) = OLD_NAME(II, 1) And Dir(FILE) <> Im_Main Then FileCopy FILE, Application.ActiveWorkbook.Path + "\OUT\" + NEW_NAME(II, 1) Cells(II + 1, 5).Value = "готов" End If Next Next 'ii MsgBox "ГОТОВО" End If Application.ScreenUpdating = 1 Application.DisplayAlerts = 1 End Sub
[/vba]
Второй изменяет текст
[vba]
Код
Sub test() Const ForReading = 1 Const TristateFalse = 0 Set FSO = CreateObject("Scripting.FileSystemObject") Filename = "C:\Users\Televnoy\Desktop\обрабатываемые файлы\OUT\m-08 1.txt" Set F = FSO.OpenTextFile(Filename, ForReading, TristateFalse) WorkStrAll = F.ReadAll WorkStrAll = Replace(WorkStrAll, "КОШКА", "ПЕС") Set F = FSO.CreateTextFile(Filename, True) F.Write (WorkStrAll) F.Close End Sub
[/vba]
Хочу последний макрос вклинить в предыдущий, до последней процедуры. Добавил переменные OLD_ID(), NEW_ID путь прописал Filename = Put_File + "OUT\" & NEW_NAME, но как то я все криво понаделал.
[vba]
Код
Sub CHANGE_NAME_FILE() Application.ScreenUpdating = 0 Application.DisplayAlerts = 0 Dim Im_Main, Put_File, sch_VERT As Variant Dim FS, KATALOG, FILE, MASSIV As Object Dim II, JJ As Integer Range("C2:C65000").Select Selection.ClearContents sch_VERT = Cells(1, 1).End(xlDown).Row - 1 Dim OLD_NAME(), NEW_NAME(), OLD_ID(), NEW_ID As Variant ReDim OLD_NAME(sch_VERT, 1), NEW_NAME(sch_VERT, 1) Range("A1:B" + Trim(Str(sch_VERT + 1))).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal OLD_NAME = Range(Cells(2, 1), Cells(2 + sch_VERT, 1)) NEW_NAME = Range(Cells(2, 2), Cells(2 + sch_VERT, 2)) '_____________________________ OLD_ID() = Range(Cells(2, 3), Cells(2 + sch_VERT, 3)) NEW_ID() = Range(Cells(2, 4), Cells(2 + sch_VERT, 4)) '_____________________________ Im_Main = ActiveWorkbook.Name Put_File = Application.ActiveWorkbook.Path + "\" Set FS = CreateObject("Scripting.FileSystemObject") Set KATALOG = FS.GetFolder(Put_File) Set MASSIV = KATALOG.Files If Dir(Put_File + "OUT\", vbDirectory) = "" Then MkDir (Put_File + "OUT\") End If If Dir(Put_File + "OUT\", vbDirectory) <> "" Then 'If Len(Dir(Put_File + "OUT\*.*")) > 0 Then 'Kill (Put_File + "OUT\*.*") 'End If '_____________________________ Const ForReading = 1 Const TristateFalse = 0 Set FSO = CreateObject("Scripting.FileSystemObject") Filename = Put_File + "OUT\" & NEW_NAME Set F = FSO.OpenTextFile(Filename, ForReading, TristateFalse) WorkStrAll = F.ReadAll WorkStrAll = Replace(WorkStrAll, OLD_ID, NEW_ID) Set F = FSO.CreateTextFile(Filename, True) F.Write (WorkStrAll) F.Close '__________________________________
For II = 1 To sch_VERT For Each FILE In MASSIV If Dir(FILE) = OLD_NAME(II, 1) And Dir(FILE) <> Im_Main Then FileCopy FILE, Application.ActiveWorkbook.Path + "\OUT\" + NEW_NAME(II, 1) Cells(II + 1, 5).Value = "готов" End If Next Next 'ii MsgBox "ГОТОВО" End If Application.ScreenUpdating = 1 Application.DisplayAlerts = 1 End Sub
модуль тест обрабатывает за раз одну переменную а в массиве у вас их 15шт.
нужно делать цикл перебирать значения в процедуру тест прописывать переменные вызывать процедуру передавая ей значения [vba]
Код
Sub test(файл as string, что as string, начто as string) Const ForReading = 1 Const TristateFalse = 0 Set FSO = CreateObject("Scripting.FileSystemObject") Filename = файл Set F = FSO.OpenTextFile(Filename, ForReading, TristateFalse) WorkStrAll = F.ReadAll WorkStrAll = Replace(WorkStrAll, что, начто) Set F = FSO.CreateTextFile(Filename, True) F.Write (WorkStrAll) F.Close End Sub
[/vba]
модуль тест обрабатывает за раз одну переменную а в массиве у вас их 15шт.
нужно делать цикл перебирать значения в процедуру тест прописывать переменные вызывать процедуру передавая ей значения [vba]
Код
Sub test(файл as string, что as string, начто as string) Const ForReading = 1 Const TristateFalse = 0 Set FSO = CreateObject("Scripting.FileSystemObject") Filename = файл Set F = FSO.OpenTextFile(Filename, ForReading, TristateFalse) WorkStrAll = F.ReadAll WorkStrAll = Replace(WorkStrAll, что, начто) Set F = FSO.CreateTextFile(Filename, True) F.Write (WorkStrAll) F.Close End Sub
Glen, K-SerJC, извините ну не могу догнать. Честно я ноль в VBA. Делаю все на интуитивном уровне. Не могу сделать =( Нельзя ли не буквами, не малыми выражениями которые я не в курсе куда запихнуть. А готовым куском кода или лучше целым. Пожалуйста.
Может я не верно объяснил задачу? . Сработал первый макрос - копировал файл с новыми названиями из списка Второй макрос - открыл файлы по списку и заменил текстовые значения из одного столбика вторым.
И да, не 15 значений их гораздо, гораздо больше. (Последние я обрабатывал 240 файлов - в ручную. Сейчас предстоит еще больше. И не одно слово. А текст этот в примере - надо менять ссылку будет. Расширение DAE, 3D модель, можно открыть текстовым редактором.
Glen, K-SerJC, извините ну не могу догнать. Честно я ноль в VBA. Делаю все на интуитивном уровне. Не могу сделать =( Нельзя ли не буквами, не малыми выражениями которые я не в курсе куда запихнуть. А готовым куском кода или лучше целым. Пожалуйста.
Может я не верно объяснил задачу? . Сработал первый макрос - копировал файл с новыми названиями из списка Второй макрос - открыл файлы по списку и заменил текстовые значения из одного столбика вторым.
И да, не 15 значений их гораздо, гораздо больше. (Последние я обрабатывал 240 файлов - в ручную. Сейчас предстоит еще больше. И не одно слово. А текст этот в примере - надо менять ссылку будет. Расширение DAE, 3D модель, можно открыть текстовым редактором.televnoy
Добился что бы не было ошибок, но замены не происходит
[vba]
Код
Sub CHANGE_NAME2_FILE() Application.ScreenUpdating = 0 Application.DisplayAlerts = 0 Dim Im_Main, Put_File, sch_VERT As Variant Dim FS, KATALOG, FILE, MASSIV As Object Dim II, JJ As Integer Range("e2:e65000").Select Selection.ClearContents sch_VERT = Cells(1, 1).End(xlDown).Row - 1 Dim OLD_NAME(), NEW_NAME(), OLD_ID(), NEW_ID() As Variant ReDim OLD_NAME(sch_VERT, 1), NEW_NAME(sch_VERT, 1), OLD_ID(sch_VERT, 1), NEW_ID(sch_VERT, 1) Range("A1:B" + Trim(Str(sch_VERT + 1))).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal OLD_NAME = Range(Cells(2, 1), Cells(2 + sch_VERT, 1)) NEW_NAME = Range(Cells(2, 2), Cells(2 + sch_VERT, 2)) '_____________________________ OLD_ID() = Range(Cells(2, 3), Cells(2 + sch_VERT, 3)) NEW_ID() = Range(Cells(2, 4), Cells(2 + sch_VERT, 4)) '_____________________________ Im_Main = ActiveWorkbook.Name Put_File = Application.ActiveWorkbook.Path + "\" Set FS = CreateObject("Scripting.FileSystemObject") Set KATALOG = FS.GetFolder(Put_File) Set MASSIV = KATALOG.Files If Dir(Put_File + "OUT\", vbDirectory) = "" Then MkDir (Put_File + "OUT\") End If
If Dir(Put_File + "OUT\", vbDirectory) <> "" Then 'If Len(Dir(Put_File + "OUT\*.*")) > 0 Then 'Kill (Put_File + "OUT\*.*") 'End If
For II = 1 To sch_VERT For Each FILE In MASSIV If Dir(FILE) = OLD_NAME(II, 1) And Dir(FILE) <> Im_Main Then FileCopy FILE, Application.ActiveWorkbook.Path + "\OUT\" + NEW_NAME(II, 1) Cells(II + 1, 5).Value = "готово" End If Next
Next 'ii
' заменяемые значения
Const ForReading = 1 Const TristateFalse = 0 Set FSO = CreateObject("Scripting.FileSystemObject") Filename = Put_File + "OUT\" & NEW_NAME(1, 1) Set F = FSO.OpenTextFile(Filename, ForReading, TristateFalse) WorkStrAll = F.ReadAll WorkStrAll = Replace(WorkStrAll, OLD_ID(1, 1), NEW_ID(1, 1)) Set F = FSO.CreateTextFile(Filename, True) F.Write (WorkStrAll) F.Close
'____________________________________
MsgBox "Готово" End If Application.ScreenUpdating = 1 Application.DisplayAlerts = 1 End Sub
[/vba]
K-SerJC, Glen,
Добился что бы не было ошибок, но замены не происходит
[vba]
Код
Sub CHANGE_NAME2_FILE() Application.ScreenUpdating = 0 Application.DisplayAlerts = 0 Dim Im_Main, Put_File, sch_VERT As Variant Dim FS, KATALOG, FILE, MASSIV As Object Dim II, JJ As Integer Range("e2:e65000").Select Selection.ClearContents sch_VERT = Cells(1, 1).End(xlDown).Row - 1 Dim OLD_NAME(), NEW_NAME(), OLD_ID(), NEW_ID() As Variant ReDim OLD_NAME(sch_VERT, 1), NEW_NAME(sch_VERT, 1), OLD_ID(sch_VERT, 1), NEW_ID(sch_VERT, 1) Range("A1:B" + Trim(Str(sch_VERT + 1))).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal OLD_NAME = Range(Cells(2, 1), Cells(2 + sch_VERT, 1)) NEW_NAME = Range(Cells(2, 2), Cells(2 + sch_VERT, 2)) '_____________________________ OLD_ID() = Range(Cells(2, 3), Cells(2 + sch_VERT, 3)) NEW_ID() = Range(Cells(2, 4), Cells(2 + sch_VERT, 4)) '_____________________________ Im_Main = ActiveWorkbook.Name Put_File = Application.ActiveWorkbook.Path + "\" Set FS = CreateObject("Scripting.FileSystemObject") Set KATALOG = FS.GetFolder(Put_File) Set MASSIV = KATALOG.Files If Dir(Put_File + "OUT\", vbDirectory) = "" Then MkDir (Put_File + "OUT\") End If
If Dir(Put_File + "OUT\", vbDirectory) <> "" Then 'If Len(Dir(Put_File + "OUT\*.*")) > 0 Then 'Kill (Put_File + "OUT\*.*") 'End If
For II = 1 To sch_VERT For Each FILE In MASSIV If Dir(FILE) = OLD_NAME(II, 1) And Dir(FILE) <> Im_Main Then FileCopy FILE, Application.ActiveWorkbook.Path + "\OUT\" + NEW_NAME(II, 1) Cells(II + 1, 5).Value = "готово" End If Next
Next 'ii
' заменяемые значения
Const ForReading = 1 Const TristateFalse = 0 Set FSO = CreateObject("Scripting.FileSystemObject") Filename = Put_File + "OUT\" & NEW_NAME(1, 1) Set F = FSO.OpenTextFile(Filename, ForReading, TristateFalse) WorkStrAll = F.ReadAll WorkStrAll = Replace(WorkStrAll, OLD_ID(1, 1), NEW_ID(1, 1)) Set F = FSO.CreateTextFile(Filename, True) F.Write (WorkStrAll) F.Close
'____________________________________
MsgBox "Готово" End If Application.ScreenUpdating = 1 Application.DisplayAlerts = 1 End Sub
а дальше в коде замены вы используете только одно значение первое (1,1) в коде нужно добавить цикл от 1 до макс значения массива (в конкретно этом случае 15) что то типа такого нужно, только я не тестировал: [vba]
Код
for f=1 to 15 Const ForReading = 1 Const TristateFalse = 0 Set FSO = CreateObject("Scripting.FileSystemObject") Filename = Put_File + "OUT\" & NEW_NAME(f, 1) Set F = FSO.OpenTextFile(Filename, ForReading, TristateFalse) WorkStrAll = F.ReadAll WorkStrAll = Replace(WorkStrAll, OLD_ID(f, 1), NEW_ID(f, 1)) Set F = FSO.CreateTextFile(Filename, True) F.Write (WorkStrAll) F.Close next f
а дальше в коде замены вы используете только одно значение первое (1,1) в коде нужно добавить цикл от 1 до макс значения массива (в конкретно этом случае 15) что то типа такого нужно, только я не тестировал: [vba]
Код
for f=1 to 15 Const ForReading = 1 Const TristateFalse = 0 Set FSO = CreateObject("Scripting.FileSystemObject") Filename = Put_File + "OUT\" & NEW_NAME(f, 1) Set F = FSO.OpenTextFile(Filename, ForReading, TristateFalse) WorkStrAll = F.ReadAll WorkStrAll = Replace(WorkStrAll, OLD_ID(f, 1), NEW_ID(f, 1)) Set F = FSO.CreateTextFile(Filename, True) F.Write (WorkStrAll) F.Close next f