Данный макрос сохраняет лист в отдельный файл в определенную папку и присваивает ему имя, которое берет из ячейки CT2. Периодически возникает совпадение имен в папке. Я останавливаю макрос, вручную меняю имя файла в ячейке и заново запускаю его. Можно ли изменить эту часть макроса так, чтобы он сперва проверил имя файла из ячейки CT2 на совпадение и если оно есть, поменял данные в ячейке СТ2 добавив к ним в конце "_1". Если имя с таким номером есть, то "_2" и т.д. пока имя из ячейки СТ2 не станет уникальным?
Данный макрос сохраняет лист в отдельный файл в определенную папку и присваивает ему имя, которое берет из ячейки CT2. Периодически возникает совпадение имен в папке. Я останавливаю макрос, вручную меняю имя файла в ячейке и заново запускаю его. Можно ли изменить эту часть макроса так, чтобы он сперва проверил имя файла из ячейки CT2 на совпадение и если оно есть, поменял данные в ячейке СТ2 добавив к ним в конце "_1". Если имя с таким номером есть, то "_2" и т.д. пока имя из ячейки СТ2 не станет уникальным?Влад777
Влад777, удобнее было бы увидеть код с обозначением переменных, а лучше полный код. Необходимо поставить проверку на существование файла:
[vba]
Код
namefile=Range("ct2") ......... if Dir "C:\Users\Admin\Documents\Таможня\2-й этап\База" <>"" then if isnumeric(right(namefile, 1)) and left(right(namefile,2),1)="_" then namefile=left(namefile, len(namefile)-2) & "_" & (cint(right(namefile, 1))+1) else namefile=namefile & "_1" end if end if ........ Range("ct2")=namefile ActiveWorkbook.SaveAs Filename:="C:\Users\Admin\Documents\Таможня\2-й этап\База\" & namefile, FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=False
[/vba]
Исправил, забыл поставить первую цифру.
Влад777, удобнее было бы увидеть код с обозначением переменных, а лучше полный код. Необходимо поставить проверку на существование файла:
[vba]
Код
namefile=Range("ct2") ......... if Dir "C:\Users\Admin\Documents\Таможня\2-й этап\База" <>"" then if isnumeric(right(namefile, 1)) and left(right(namefile,2),1)="_" then namefile=left(namefile, len(namefile)-2) & "_" & (cint(right(namefile, 1))+1) else namefile=namefile & "_1" end if end if ........ Range("ct2")=namefile ActiveWorkbook.SaveAs Filename:="C:\Users\Admin\Documents\Таможня\2-й этап\База\" & namefile, FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=False
Set c = Columns(2).Find("*", searchdirection:=xlPrevious) If c Is Nothing Then cells(1, 2).Select Else c.Offset(1, 0).Select End If Set wb3 = Workbooks("Книга3.xlsm") shName = wb3.ActiveSheet.Name ActiveCell.FormulaR1C1 = "=[" & wb3.Name & "]" & shName & "!R2C98" iRow = Columns("B").Find(What:="*", LookIn:=xlValues, searchdirection:=xlPrevious, SearchOrder:=xlByRows).Row Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Set c = Columns(4).Find("*", searchdirection:=xlPrevious) If c Is Nothing Then cells(1, 4).Select Else c.Offset(1, 0).Select End If Set wb3 = Workbooks("Книга3.xlsm") shName = wb3.ActiveSheet.Name ActiveCell.FormulaR1C1 = "=[" & wb3.Name & "]" & shName & "!R2C50" iRow = Columns("B").Find(What:="*", LookIn:=xlValues, searchdirection:=xlPrevious, SearchOrder:=xlByRows).Row Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Set c = Columns(5).Find("*", searchdirection:=xlPrevious) If c Is Nothing Then cells(1, 5).Select Else c.Offset(1, 0).Select End If Set wb3 = Workbooks("Книга3.xlsm") shName = wb3.ActiveSheet.Name ActiveCell.FormulaR1C1 = "=[" & wb3.Name & "]" & shName & "!R2C51" iRow = Columns("B").Find(What:="*", LookIn:=xlValues, searchdirection:=xlPrevious, SearchOrder:=xlByRows).Row Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Windows("Книга3.xlsm").Activate Set wb3 = Workbooks("Книга3.xlsm") shName = wb3.ActiveSheet.Name cells.Select Selection.Copy Workbooks.Add ActiveSheet.Paste Range("CT2").Select Application.CutCopyMode = False Selection.Copy Application.CutCopyMode = False ChDir "C:\Users\Admin\Documents\Таможня\2-й этап\База" ActiveWorkbook.SaveAs Filename:="C:\Users\Admin\Documents\Таможня\2-й этап\База\" & Range("ct2"), FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=False
Windows("Приложение.xlsx").Activate Sheets("ПРИЛОЖЕНИЕ 1").Select Set wb = ActiveWorkbook Set sh = ActiveWorkbook.ActiveSheet LastCell = sh.UsedRange.Rows.Count
For rr = 2 To LastCell If sh.cells(rr, "G") = "" Then If sh.cells(rr, "B") <> "" Then 'что бы столбец с именем файла не был пуст filee = sh.cells(rr, "B").Value & ".xls"
Set wb2 = Workbooks.Open("C:\Users\Admin\Documents\Таможня\2-й этап\База\" & filee) Set sh2 = wb2.Sheets(1) iET = sh2.cells(Rows.Count, 63).End(xlUp).Row sum1 = WorksheetFunction.Sum(sh2.Range("BL2").Resize(iET - 1, 1)) sum2 = WorksheetFunction.Sum(sh2.Range("BH2").Resize(iET - 1, 1))
sh.cells(rr, "G") = sum1 sh.cells(rr, "I") = sum2 wb2.Close False End If End If Next
Set c = Columns(2).Find("*", searchdirection:=xlPrevious) If c Is Nothing Then cells(1, 2).Select Else c.Offset(1, 0).Select End If Set wb3 = Workbooks("Книга3.xlsm") shName = wb3.ActiveSheet.Name ActiveCell.FormulaR1C1 = "=[" & wb3.Name & "]" & shName & "!R2C98" iRow = Columns("B").Find(What:="*", LookIn:=xlValues, searchdirection:=xlPrevious, SearchOrder:=xlByRows).Row Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Set c = Columns(4).Find("*", searchdirection:=xlPrevious) If c Is Nothing Then cells(1, 4).Select Else c.Offset(1, 0).Select End If Set wb3 = Workbooks("Книга3.xlsm") shName = wb3.ActiveSheet.Name ActiveCell.FormulaR1C1 = "=[" & wb3.Name & "]" & shName & "!R2C50" iRow = Columns("B").Find(What:="*", LookIn:=xlValues, searchdirection:=xlPrevious, SearchOrder:=xlByRows).Row Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Set c = Columns(5).Find("*", searchdirection:=xlPrevious) If c Is Nothing Then cells(1, 5).Select Else c.Offset(1, 0).Select End If Set wb3 = Workbooks("Книга3.xlsm") shName = wb3.ActiveSheet.Name ActiveCell.FormulaR1C1 = "=[" & wb3.Name & "]" & shName & "!R2C51" iRow = Columns("B").Find(What:="*", LookIn:=xlValues, searchdirection:=xlPrevious, SearchOrder:=xlByRows).Row Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Windows("Книга3.xlsm").Activate Set wb3 = Workbooks("Книга3.xlsm") shName = wb3.ActiveSheet.Name cells.Select Selection.Copy Workbooks.Add ActiveSheet.Paste Range("CT2").Select Application.CutCopyMode = False Selection.Copy Application.CutCopyMode = False ChDir "C:\Users\Admin\Documents\Таможня\2-й этап\База" ActiveWorkbook.SaveAs Filename:="C:\Users\Admin\Documents\Таможня\2-й этап\База\" & Range("ct2"), FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=False
Windows("Приложение.xlsx").Activate Sheets("ПРИЛОЖЕНИЕ 1").Select Set wb = ActiveWorkbook Set sh = ActiveWorkbook.ActiveSheet LastCell = sh.UsedRange.Rows.Count
For rr = 2 To LastCell If sh.cells(rr, "G") = "" Then If sh.cells(rr, "B") <> "" Then 'что бы столбец с именем файла не был пуст filee = sh.cells(rr, "B").Value & ".xls"
Set wb2 = Workbooks.Open("C:\Users\Admin\Documents\Таможня\2-й этап\База\" & filee) Set sh2 = wb2.Sheets(1) iET = sh2.cells(Rows.Count, 63).End(xlUp).Row sum1 = WorksheetFunction.Sum(sh2.Range("BL2").Resize(iET - 1, 1)) sum2 = WorksheetFunction.Sum(sh2.Range("BH2").Resize(iET - 1, 1))
sh.cells(rr, "G") = sum1 sh.cells(rr, "I") = sum2 wb2.Close False End If End If Next
Влад777, у меня было немного времени, но в Вашем коде я чёт не оч смог разобраться, в общем поставил, как мне кажется в нужном месте... [vba]
Код
Sub books() Windows("Книга3.xlsm").Activate Dim sh As Worksheet For Each sh In ActiveWorkbook.Worksheets sh.name = "1_" & sheet.Index Next For Each sheet In ActiveWorkbook.Worksheets sh.name = sheet.Index Next For Each sh In ActiveWorkbook.Sheets Windows("Приложение.xlsx").Activate Sheets("ПРИЛОЖЕНИЕ 1").Select Set c = Columns(2).Find("*", searchdirection:=xlPrevious) If c Is Nothing Then Cells(1, 2).Select Else c.Offset(1, 0).Select End If Set wb3 = Workbooks("Книга3.xlsm") shName = wb3.ActiveSheet.name ActiveCell.FormulaR1C1 = "=[" & wb3.name & "]" & shName & "!R2C98" iRow = Columns("B").Find(What:="*", LookIn:=xlValues, searchdirection:=xlPrevious, SearchOrder:=xlByRows).Row Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Set c = Columns(4).Find("*", searchdirection:=xlPrevious) If c Is Nothing Then Cells(1, 4).Select Else c.Offset(1, 0).Select End If Set wb3 = Workbooks("Книга3.xlsm") shName = wb3.ActiveSheet.name ActiveCell.FormulaR1C1 = "=[" & wb3.name & "]" & shName & "!R2C50" iRow = Columns("B").Find(What:="*", LookIn:=xlValues, searchdirection:=xlPrevious, SearchOrder:=xlByRows).Row Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Set c = Columns(5).Find("*", searchdirection:=xlPrevious) If c Is Nothing Then Cells(1, 5).Select Else c.Offset(1, 0).Select End If Set wb3 = Workbooks("Книга3.xlsm") shName = wb3.ActiveSheet.name ActiveCell.FormulaR1C1 = "=[" & wb3.name & "]" & shName & "!R2C51" iRow = Columns("B").Find(What:="*", LookIn:=xlValues, searchdirection:=xlPrevious, SearchOrder:=xlByRows).Row Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Windows("Книга3.xlsm").Activate Set wb3 = Workbooks("Книга3.xlsm") shName = wb3.ActiveSheet.name Cells.Select Selection.Copy Workbooks.Add ActiveSheet.Paste Range("CT2").Select NameFile$ = Range("ct2") Application.CutCopyMode = False ' Зачем? Selection.Copy ' Зачем? Application.CutCopyMode = False ' Зачем?
ChDir "C:\Users\Admin\Documents\Таможня\2-й этап\База" ' Зачем? If Dir("C:\Users\Admin\Documents\Таможня\2-й этап\База") <> "" Then If IsNumeric(Right(NameFile, 1)) And Left(Right(NameFile, 2), 1) = "_" Then NameFile = Left(NameFile, Len(NameFile) - 2) & "_" & (CInt(Right(NameFile, 1)) + 1) Else NameFile = NameFile & "_1" End If End If Range("ct2") = NameFile ActiveWorkbook.SaveAs Filename:="C:\Users\Admin\Documents\Таможня\2-й этап\База\" & NameFile, FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=False
Windows("Приложение.xlsx").Activate Sheets("ПРИЛОЖЕНИЕ 1").Select Set WB = ActiveWorkbook Set sh = ActiveWorkbook.ActiveSheet LastCell = sh.UsedRange.Rows.Count
For rr = 2 To LastCell If sh.Cells(rr, "G") = "" Then If sh.Cells(rr, "B") <> "" Then 'что бы столбец с именем файла не был пуст filee = sh.Cells(rr, "B").Value & ".xls"
Set wb2 = Workbooks.Open("C:\Users\Admin\Documents\Таможня\2-й этап\База\" & filee) Set sh2 = wb2.Sheets(1) iET = sh2.Cells(Rows.Count, 63).End(xlUp).Row sum1 = WorksheetFunction.Sum(sh2.Range("BL2").Resize(iET - 1, 1)) sum2 = WorksheetFunction.Sum(sh2.Range("BH2").Resize(iET - 1, 1))
sh.Cells(rr, "G") = sum1 sh.Cells(rr, "I") = sum2 wb2.Close False End If End If Next
Влад777, у меня было немного времени, но в Вашем коде я чёт не оч смог разобраться, в общем поставил, как мне кажется в нужном месте... [vba]
Код
Sub books() Windows("Книга3.xlsm").Activate Dim sh As Worksheet For Each sh In ActiveWorkbook.Worksheets sh.name = "1_" & sheet.Index Next For Each sheet In ActiveWorkbook.Worksheets sh.name = sheet.Index Next For Each sh In ActiveWorkbook.Sheets Windows("Приложение.xlsx").Activate Sheets("ПРИЛОЖЕНИЕ 1").Select Set c = Columns(2).Find("*", searchdirection:=xlPrevious) If c Is Nothing Then Cells(1, 2).Select Else c.Offset(1, 0).Select End If Set wb3 = Workbooks("Книга3.xlsm") shName = wb3.ActiveSheet.name ActiveCell.FormulaR1C1 = "=[" & wb3.name & "]" & shName & "!R2C98" iRow = Columns("B").Find(What:="*", LookIn:=xlValues, searchdirection:=xlPrevious, SearchOrder:=xlByRows).Row Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Set c = Columns(4).Find("*", searchdirection:=xlPrevious) If c Is Nothing Then Cells(1, 4).Select Else c.Offset(1, 0).Select End If Set wb3 = Workbooks("Книга3.xlsm") shName = wb3.ActiveSheet.name ActiveCell.FormulaR1C1 = "=[" & wb3.name & "]" & shName & "!R2C50" iRow = Columns("B").Find(What:="*", LookIn:=xlValues, searchdirection:=xlPrevious, SearchOrder:=xlByRows).Row Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Set c = Columns(5).Find("*", searchdirection:=xlPrevious) If c Is Nothing Then Cells(1, 5).Select Else c.Offset(1, 0).Select End If Set wb3 = Workbooks("Книга3.xlsm") shName = wb3.ActiveSheet.name ActiveCell.FormulaR1C1 = "=[" & wb3.name & "]" & shName & "!R2C51" iRow = Columns("B").Find(What:="*", LookIn:=xlValues, searchdirection:=xlPrevious, SearchOrder:=xlByRows).Row Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Windows("Книга3.xlsm").Activate Set wb3 = Workbooks("Книга3.xlsm") shName = wb3.ActiveSheet.name Cells.Select Selection.Copy Workbooks.Add ActiveSheet.Paste Range("CT2").Select NameFile$ = Range("ct2") Application.CutCopyMode = False ' Зачем? Selection.Copy ' Зачем? Application.CutCopyMode = False ' Зачем?
ChDir "C:\Users\Admin\Documents\Таможня\2-й этап\База" ' Зачем? If Dir("C:\Users\Admin\Documents\Таможня\2-й этап\База") <> "" Then If IsNumeric(Right(NameFile, 1)) And Left(Right(NameFile, 2), 1) = "_" Then NameFile = Left(NameFile, Len(NameFile) - 2) & "_" & (CInt(Right(NameFile, 1)) + 1) Else NameFile = NameFile & "_1" End If End If Range("ct2") = NameFile ActiveWorkbook.SaveAs Filename:="C:\Users\Admin\Documents\Таможня\2-й этап\База\" & NameFile, FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=False
Windows("Приложение.xlsx").Activate Sheets("ПРИЛОЖЕНИЕ 1").Select Set WB = ActiveWorkbook Set sh = ActiveWorkbook.ActiveSheet LastCell = sh.UsedRange.Rows.Count
For rr = 2 To LastCell If sh.Cells(rr, "G") = "" Then If sh.Cells(rr, "B") <> "" Then 'что бы столбец с именем файла не был пуст filee = sh.Cells(rr, "B").Value & ".xls"
Set wb2 = Workbooks.Open("C:\Users\Admin\Documents\Таможня\2-й этап\База\" & filee) Set sh2 = wb2.Sheets(1) iET = sh2.Cells(Rows.Count, 63).End(xlUp).Row sum1 = WorksheetFunction.Sum(sh2.Range("BL2").Resize(iET - 1, 1)) sum2 = WorksheetFunction.Sum(sh2.Range("BH2").Resize(iET - 1, 1))
sh.Cells(rr, "G") = sum1 sh.Cells(rr, "I") = sum2 wb2.Close False End If End If Next
Roman777, Если я правильно понимаю - макрос присваивает файлу имя с единичкой. Если имя с единицей есть - он прекращается работу и говорит что файл с таким именем в системе есть..Т.е. не происходит цикла (дальнейшего присвоения цифр 2,3 и т.д.)
Roman777, Если я правильно понимаю - макрос присваивает файлу имя с единичкой. Если имя с единицей есть - он прекращается работу и говорит что файл с таким именем в системе есть..Т.е. не происходит цикла (дальнейшего присвоения цифр 2,3 и т.д.)Влад777
Влад777, скиньте, пожалуйста, файлик-пример, с которым Вы работаете, так будет гораздо быстрее... [vba]
Код
If IsNumeric(Right(NameFile, 1)) And Left(Right(NameFile, 2), 1) = "_" Then NameFile = Left(NameFile, Len(NameFile) - 2) & "_" & (CInt(Right(NameFile, 1)) + 1) Else NameFile = NameFile & "_1" End If End If
[/vba] В этом условии я предусмотрел (просто не тестил) что если имя будет заканчиваться на цифру и второй символ справа "_", тогда имени присвоить значение - конечная цифра+1 Если же условие не выполняется - тоесть имя не соотвествует окончанию "_1..2..итд" то имя=имя_1
Влад777, скиньте, пожалуйста, файлик-пример, с которым Вы работаете, так будет гораздо быстрее... [vba]
Код
If IsNumeric(Right(NameFile, 1)) And Left(Right(NameFile, 2), 1) = "_" Then NameFile = Left(NameFile, Len(NameFile) - 2) & "_" & (CInt(Right(NameFile, 1)) + 1) Else NameFile = NameFile & "_1" End If End If
[/vba] В этом условии я предусмотрел (просто не тестил) что если имя будет заканчиваться на цифру и второй символ справа "_", тогда имени присвоить значение - конечная цифра+1 Если же условие не выполняется - тоесть имя не соотвествует окончанию "_1..2..итд" то имя=имя_1Roman777
Roman777, Прошу прощения - пишу уже из дома. поэтому просто своял файлик-пример на коленке...Макрос копирует содержимое листа в новый файл и пытается сохранить его в папке под именем, указанном в ячейке CT2. Имя в этой ячейке изначально идет без цифр и подчеркиваний (причем, подчеркивание, это мое изобретение - можно впоследствии обойтись, наверное, добавлением просто цифр). Проблема в том, что в этой папке уже может быть файл с таким именем ("ПРОФИЛЬ", как в примере). Поэтому, необходимо, чтобы макрос проверил что такое имя файла в папке есть (это я уже понял в вашем коде) и в случае совпадения прибавил бы к имени 1 (получится "ПРОФИЛЬ1) и сохранил под этим именем. Если файл с именем "Профиль1" тоже есть, то макрос прибавил еще 1 и пытался сохранить под именем "ПРОФИЛЬ2" и т.д. до тех пор пока с помощью цифр не получится уникальное имя, под которым можно сохранить файл в директории.
Roman777, Прошу прощения - пишу уже из дома. поэтому просто своял файлик-пример на коленке...Макрос копирует содержимое листа в новый файл и пытается сохранить его в папке под именем, указанном в ячейке CT2. Имя в этой ячейке изначально идет без цифр и подчеркиваний (причем, подчеркивание, это мое изобретение - можно впоследствии обойтись, наверное, добавлением просто цифр). Проблема в том, что в этой папке уже может быть файл с таким именем ("ПРОФИЛЬ", как в примере). Поэтому, необходимо, чтобы макрос проверил что такое имя файла в папке есть (это я уже понял в вашем коде) и в случае совпадения прибавил бы к имени 1 (получится "ПРОФИЛЬ1) и сохранил под этим именем. Если файл с именем "Профиль1" тоже есть, то макрос прибавил еще 1 и пытался сохранить под именем "ПРОФИЛЬ2" и т.д. до тех пор пока с помощью цифр не получится уникальное имя, под которым можно сохранить файл в директории.Влад777
Влад777, Приношу извинения, только сейчас смог зайти - глянуть. Я тупанул чутка, не проверить было, сейчас глянул, ошибочка была, не указал расширение файла, да и "\Имяфайла" забыл добавить =))): проверка должна проверять конечный файл с полным путём. Попробуйте так: [vba]
Код
ChDir "C:\Users\Admin\Documents\Таможня\2-й этап\База" ' Зачем? If Dir("C:\Users\Admin\Documents\Таможня\2-й этап\База\" & NameFile & ".xls" ) <> "" Then If IsNumeric(Right(NameFile, 1)) And Left(Right(NameFile, 2), 1) = "_" Then NameFile = Left(NameFile, Len(NameFile) - 2) & "_" & (CInt(Right(NameFile, 1)) + 1) Else NameFile = NameFile & "_1" End If End If Range("ct2") = NameFile
[/vba]
Влад777, Приношу извинения, только сейчас смог зайти - глянуть. Я тупанул чутка, не проверить было, сейчас глянул, ошибочка была, не указал расширение файла, да и "\Имяфайла" забыл добавить =))): проверка должна проверять конечный файл с полным путём. Попробуйте так: [vba]
Код
ChDir "C:\Users\Admin\Documents\Таможня\2-й этап\База" ' Зачем? If Dir("C:\Users\Admin\Documents\Таможня\2-й этап\База\" & NameFile & ".xls" ) <> "" Then If IsNumeric(Right(NameFile, 1)) And Left(Right(NameFile, 2), 1) = "_" Then NameFile = Left(NameFile, Len(NameFile) - 2) & "_" & (CInt(Right(NameFile, 1)) + 1) Else NameFile = NameFile & "_1" End If End If Range("ct2") = NameFile
Roman777, К сожалению - не работает. Он создает файл с именем "Профиль_1". Всегда создает файл с этим именем. Соответственно, эксель начинает ругаться на совпадение и макрос приходится останавливать. Макрос не осуществляет перебор вариантов. Он проверяет только вариант с именем файла "Профиль_1" и все.
Я писал ранее и в примере есть - изначальное имя файла из ячейки СТ2 - без цифр и подчеркиваний. Цифры появляются, когда начинается поиск уникального имени файла (подчеркивание можно вообще убрать). Если я правильно понял, то нужно, чтобы при совпадении имени файла он приписывал к содержимому ячейки СТ2 единицу и проверял опять на уникальность. В случае совпадения потом прибавлял еще единицу ("Профиль2") и вновь проверял на совпадение и так до тех пор, пока не получится уникальное имя файла. Нужен цикл с условием проверки.
Я не понимаю, как написать на VBA так, чтобы макрос приписывал к содержимому конкретной ячейки единицу, потом еще и еще.
Пример Manyasha близок в той его части, когда проверяется имя файла в директории на уникальность. Но у меня нет знаний VBA, чтобы его исправить под ситуацию с именем из ячейки СТ2. Может взять оттуда общую идею?
Roman777, К сожалению - не работает. Он создает файл с именем "Профиль_1". Всегда создает файл с этим именем. Соответственно, эксель начинает ругаться на совпадение и макрос приходится останавливать. Макрос не осуществляет перебор вариантов. Он проверяет только вариант с именем файла "Профиль_1" и все.
Я писал ранее и в примере есть - изначальное имя файла из ячейки СТ2 - без цифр и подчеркиваний. Цифры появляются, когда начинается поиск уникального имени файла (подчеркивание можно вообще убрать). Если я правильно понял, то нужно, чтобы при совпадении имени файла он приписывал к содержимому ячейки СТ2 единицу и проверял опять на уникальность. В случае совпадения потом прибавлял еще единицу ("Профиль2") и вновь проверял на совпадение и так до тех пор, пока не получится уникальное имя файла. Нужен цикл с условием проверки.
Я не понимаю, как написать на VBA так, чтобы макрос приписывал к содержимому конкретной ячейки единицу, потом еще и еще.
Пример Manyasha близок в той его части, когда проверяется имя файла в директории на уникальность. Но у меня нет знаний VBA, чтобы его исправить под ситуацию с именем из ячейки СТ2. Может взять оттуда общую идею?Влад777
Я вам поверил, что у вас в ячейке имя файла... [vba]
Код
Sub Save_As() Dim sBaseName$, sBaseNameNew$, i& sBaseName ="C:\Users\Admin\Documents\Таможня\2-й этап\База\" & Range("ct2") sBaseNameNew = sBaseName Do While Dir(sBaseNameNew & "xls") <> "" i = i + 1 sBaseNameNew = sBaseName & "(" & i & ")" Loop ActiveWorkbook.SaveAs Filename:=sBaseNameNew , FileFormat:=xlNormal End Sub
[/vba]
Я вам поверил, что у вас в ячейке имя файла... [vba]
Код
Sub Save_As() Dim sBaseName$, sBaseNameNew$, i& sBaseName ="C:\Users\Admin\Documents\Таможня\2-й этап\База\" & Range("ct2") sBaseNameNew = sBaseName Do While Dir(sBaseNameNew & "xls") <> "" i = i + 1 sBaseNameNew = sBaseName & "(" & i & ")" Loop ActiveWorkbook.SaveAs Filename:=sBaseNameNew , FileFormat:=xlNormal End Sub
RAN, Сейчас просто создает файл "Профиль", говорит что такое имя есть и все. Это было у меня и раньше, эту проблему совпадения имен я и пытаюсь решить....
Не вижу противоречий - в ячейке CT2 лежит имя файла, к которому, в случае совпаднеия, надо прибавлять цифры.
RAN, Сейчас просто создает файл "Профиль", говорит что такое имя есть и все. Это было у меня и раньше, эту проблему совпадения имен я и пытаюсь решить....
Не вижу противоречий - в ячейке CT2 лежит имя файла, к которому, в случае совпаднеия, надо прибавлять цифры.Влад777
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
