Здравствуйте. Помогите сделать программу в VBA,которая будет искать файлы по таблице(файлы будут в папке до 3 уровня,лучше в корне диска D),а вставлять их нужно будет в новую папку которая будет создана или на рабочем столе\или в той же директории. Но есть несколько хитростей у этой задаче.(Поэтому в папке будет табличка с пробным задание[табл.V1],и 2 примера ее решения[Примеры результатов],а так же файлы по которым будет идти поиск[Layout] и там 3 подпапки[Blue];[White];[Yellow],а в них,в свою очередь есть еще подпапки от [98] до [164] с опред.интервалом). Сами файлы-изображение формата .tiff СУТЬ В Том,что файлы в папки [Layout] неизменны,а по табличке [табл.V1] которая будет постоянно меняться,нужно будет создавать каждый раз новую папку с тем набором файлов,который указан в этой табл. Будет постоянно происходить копирование файлов с одинаковым именем,можно просто подписывать датавремя\копия1'копия2 или как вам будет легче,но в идеале чтобы файл имел имя=[свое имя+путь откуда он взялся],если их будет несколько,тогда имя=[свое имя+путь откуда он взялся]1;2;3и тд,но это по возможности. если что то нетак,давай те я со своей стороны изменю,например конечные имена файлов и т.д.
А делать это нужно так,если напр. стоит цифра 1 напротив цвета White в табл. размера 110,тогда нужно сделать один белый комплект 110 размера,а это по одному файлу:1,2,3,4,5(т.е. эти 5 файлов образуют комплект) НО очень важно,если таких комплектов нужно 2 и больше,тогда вместо файлов 3,4,5 нужно использовать 33,44,55(по сути это теже файлы,только спаринные),т.е. чтобы не кидать 2 файлы [3] нужно закинуть один файл [33]. Это делается для файлов 3,4,5, файлы 1 и 2 незаменяемые.
Т.е. если нужно закинуть BLUE размера 98 -3 шт.,тогда нужно закинуть из папки [Layout\Blue\98] по 3 файлы [1],[2] и еще по одному [33,44,55] и еще [3,4,5]. Думаю, если посмотрите на пример,станет легче)
Здравствуйте. Помогите сделать программу в VBA,которая будет искать файлы по таблице(файлы будут в папке до 3 уровня,лучше в корне диска D),а вставлять их нужно будет в новую папку которая будет создана или на рабочем столе\или в той же директории. Но есть несколько хитростей у этой задаче.(Поэтому в папке будет табличка с пробным задание[табл.V1],и 2 примера ее решения[Примеры результатов],а так же файлы по которым будет идти поиск[Layout] и там 3 подпапки[Blue];[White];[Yellow],а в них,в свою очередь есть еще подпапки от [98] до [164] с опред.интервалом). Сами файлы-изображение формата .tiff СУТЬ В Том,что файлы в папки [Layout] неизменны,а по табличке [табл.V1] которая будет постоянно меняться,нужно будет создавать каждый раз новую папку с тем набором файлов,который указан в этой табл. Будет постоянно происходить копирование файлов с одинаковым именем,можно просто подписывать датавремя\копия1'копия2 или как вам будет легче,но в идеале чтобы файл имел имя=[свое имя+путь откуда он взялся],если их будет несколько,тогда имя=[свое имя+путь откуда он взялся]1;2;3и тд,но это по возможности. если что то нетак,давай те я со своей стороны изменю,например конечные имена файлов и т.д.
А делать это нужно так,если напр. стоит цифра 1 напротив цвета White в табл. размера 110,тогда нужно сделать один белый комплект 110 размера,а это по одному файлу:1,2,3,4,5(т.е. эти 5 файлов образуют комплект) НО очень важно,если таких комплектов нужно 2 и больше,тогда вместо файлов 3,4,5 нужно использовать 33,44,55(по сути это теже файлы,только спаринные),т.е. чтобы не кидать 2 файлы [3] нужно закинуть один файл [33]. Это делается для файлов 3,4,5, файлы 1 и 2 незаменяемые.
Т.е. если нужно закинуть BLUE размера 98 -3 шт.,тогда нужно закинуть из папки [Layout\Blue\98] по 3 файлы [1],[2] и еще по одному [33,44,55] и еще [3,4,5]. Думаю, если посмотрите на пример,станет легче)олежа525
Sub Copfyiles() Const sPath1$ = "d:\layout\" Dim S$, sPath2$, sFrom$, sTo$ Dim cell As Range, i%, j% sPath2 = CreateObject("Shell.Application").Namespace(0).self.path & "\" & [G2] & "\" If Dir(sPath2, 16) = "" Then MkDir sPath2 On Error Resume Next With [A2].CurrentRegion For Each cell In .Offset(1, 1).SpecialCells(xlCellTypeConstants, 1).Cells S = Intersect(cell.EntireColumn, .Rows(1)) & "\" & Intersect(cell.EntireRow, .Columns(1)) & "\" sFrom = sPath1 & S sTo = sPath2 & Replace(S, "\", "_") For i = 1 To 5 For j = 1 To cell Select Case True Case i < 3 Or (j = cell And j Mod 2) FileCopy sFrom & i & ".tif", sTo & i & "-" & j & ".tif" Case (j Mod 2) = 0 FileCopy sFrom & i * 11 & ".tif", sTo & i * 11 & "-" & j \ 2 & ".tif" End Select Next Next Next End With If MsgBox("Готово!" & vbLf & "Открыть папку?", 36) = 6 Then Shell "explorer """ & sPath2 & """", 1 End Sub
[/vba]
Здравствуйте. Как-то так [vba]
Код
Sub Copfyiles() Const sPath1$ = "d:\layout\" Dim S$, sPath2$, sFrom$, sTo$ Dim cell As Range, i%, j% sPath2 = CreateObject("Shell.Application").Namespace(0).self.path & "\" & [G2] & "\" If Dir(sPath2, 16) = "" Then MkDir sPath2 On Error Resume Next With [A2].CurrentRegion For Each cell In .Offset(1, 1).SpecialCells(xlCellTypeConstants, 1).Cells S = Intersect(cell.EntireColumn, .Rows(1)) & "\" & Intersect(cell.EntireRow, .Columns(1)) & "\" sFrom = sPath1 & S sTo = sPath2 & Replace(S, "\", "_") For i = 1 To 5 For j = 1 To cell Select Case True Case i < 3 Or (j = cell And j Mod 2) FileCopy sFrom & i & ".tif", sTo & i & "-" & j & ".tif" Case (j Mod 2) = 0 FileCopy sFrom & i * 11 & ".tif", sTo & i * 11 & "-" & j \ 2 & ".tif" End Select Next Next Next End With If MsgBox("Готово!" & vbLf & "Открыть папку?", 36) = 6 Then Shell "explorer """ & sPath2 & """", 1 End Sub
krosav4ig, Огромное спасибо! Подскажи пожалуйста,а как сделать чтобы скрипт работал когда в табличке данные берутся с другой табл) ну т.е. там написано не какое то определенное значение,а вот так"=Лист1!K3" ,и с формулами тоже не работает.
krosav4ig, Огромное спасибо! Подскажи пожалуйста,а как сделать чтобы скрипт работал когда в табличке данные берутся с другой табл) ну т.е. там написано не какое то определенное значение,а вот так"=Лист1!K3" ,и с формулами тоже не работает.олежа525
Sub Copfyiles() Const sPath1$ = "d:\layout\" Dim S$, sPath2$, sFrom$, sTo$ Dim cell As Range, r As Range, i%, j%, n sPath2 = CreateObject("Shell.Application").Namespace(0).self.path & "\" & [G2] & "\" If Dir(sPath2, 16) = "" Then MkDir sPath2 On Error Resume Next With [A2].CurrentRegion With .Offset(1, 1) Set r = .SpecialCells(xlCellTypeFormulas, 1) If r Is Nothing Then Set r = .SpecialCells(xlCellTypeConstants, 1) Else Set r = Union(r, .SpecialCells(xlCellTypeConstants, 1)) End If If r Is Nothing Then Exit Sub End With For Each cell In r.Cells S = Intersect(cell.EntireColumn, .Rows(1)) & "\" & Intersect(cell.EntireRow, .Columns(1)) & "\" sFrom = sPath1 & S sTo = sPath2 & Replace(S, "\", "_") For i = 1 To 5 For j = 1 To cell Select Case True Case i < 3 Or (j = cell And j Mod 2) FileCopy sFrom & i & ".tif", sTo & i & "-" & j & ".tif" Case (j Mod 2) = 0 FileCopy sFrom & i * 11 & ".tif", sTo & i * 11 & "-" & j \ 2 & ".tif" End Select Next Next Next End With Set r = Nothing If MsgBox("Готово!" & vbLf & "Открыть папку?", 36) = 6 Then Shell "explorer """ & sPath2 & """", 1 End Sub
[/vba]
можно так [vba]
Код
Sub Copfyiles() Const sPath1$ = "d:\layout\" Dim S$, sPath2$, sFrom$, sTo$ Dim cell As Range, r As Range, i%, j%, n sPath2 = CreateObject("Shell.Application").Namespace(0).self.path & "\" & [G2] & "\" If Dir(sPath2, 16) = "" Then MkDir sPath2 On Error Resume Next With [A2].CurrentRegion With .Offset(1, 1) Set r = .SpecialCells(xlCellTypeFormulas, 1) If r Is Nothing Then Set r = .SpecialCells(xlCellTypeConstants, 1) Else Set r = Union(r, .SpecialCells(xlCellTypeConstants, 1)) End If If r Is Nothing Then Exit Sub End With For Each cell In r.Cells S = Intersect(cell.EntireColumn, .Rows(1)) & "\" & Intersect(cell.EntireRow, .Columns(1)) & "\" sFrom = sPath1 & S sTo = sPath2 & Replace(S, "\", "_") For i = 1 To 5 For j = 1 To cell Select Case True Case i < 3 Or (j = cell And j Mod 2) FileCopy sFrom & i & ".tif", sTo & i & "-" & j & ".tif" Case (j Mod 2) = 0 FileCopy sFrom & i * 11 & ".tif", sTo & i * 11 & "-" & j \ 2 & ".tif" End Select Next Next Next End With Set r = Nothing If MsgBox("Готово!" & vbLf & "Открыть папку?", 36) = 6 Then Shell "explorer """ & sPath2 & """", 1 End Sub
странно, у меня все нормально отрабатывает, создается 17 файлов Upd. А, вот в чем дело, я запускал макрос из VBE, для того чтобы работало, нужно переназначить макрос для фигуры на листе Rip (2)
странно, у меня все нормально отрабатывает, создается 17 файлов Upd. А, вот в чем дело, я запускал макрос из VBE, для того чтобы работало, нужно переназначить макрос для фигуры на листе Rip (2)krosav4ig
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
