Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
добавление новых строк в таблицу с ссылками на файлы в папке, макрос добавляет строки к последней найденной ячейке столбца
 
#1
06.06.2016 15:49:22
Уважаемые форумчане, помогите  пожалуйста дополнить макрос:
Код
Private Sub Worksheet_Change(ByVal Target As Range)
Dim j As Integer
j = Target.Column
Dim i As Integer
i = Target.Row
Dim k
Dim di
Dim fn As String
di = ThisWorkbook.Sheets("Данные").Cells(2, 1)
If j = 3 Then
k = Cells(i, 2)
     fn = Dir(di & k & ".xlsx")
       If fn = k & ".xlsx" Then
        Range("D1:AS1").Select //  В этом диапазонне ссылки на ячейки файла-бланка
        Selection.Copy
        Cells(i, 4).Select
        Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        ActiveSheet.Rows(i).Replace what:="000001", Replacement:=k
        Rows(i).EntireRow.AutoFit
        Cells(i, 3).Select
        Cells(i, 3).Activate
        ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
        di & k & ".xlsx"
    Else
    MsgBox "такого номера нет в бланках"
    Exit Sub
    End If
End If
End Sub
Макрос служит для добавления по одной строчке бланков, которые находятся в папке, их номера  000001...n, при  выделении двух последних ячеек в столбце C и их протяжки на 1 ячейку, создается ссылка на файл и заполняется строка из  ячеек этого файла. Постоянно приходится   добавлять по одной строке.
хотелось бы чтоб протягивался до последнего номера файла в папке по нажатию кнопки. Помогите, подскажите, сам макросы писал только по записи
Изменено: welsher - 07.06.2016 13:13:58
 
 
 
#2
06.06.2016 17:18:10
welsher, по Вашему коду:
Код
Dim i As Integer
i = Target.Row
Integer - Хранение целых чисел от -32768 до 32767
Поэтому лучше так:
Код
Dim i As Long
Дальше:
Код
        Cells(i, 3).Select
        Cells(i, 3).Activate
Не понял для чего. Помоему результат обоих действий одинаков...
Код
di = ThisWorkbook.Sheets("Данные").Cells(2, 1)
...
"D1:AS1").Select //  В этом диапазоННе ссылки на ячейки файла-бланка
ПМСМ, для понимания не хватает файла-примера с этими данными.
Изменено: Ренат - 07.06.2016 18:45:05 (убрал цитирования (доделал то, что начали модераторы, наверно) :))
Успехов. И мне того же. Благодарю. :)
 
 
 
#3
06.06.2016 18:16:03
Выложил файл для примера
 
 
 
#4
06.06.2016 18:37:43
Код
'C:\Users\chabinv\Documents\БЛАНКИ\[000001.xlsx]Info'
Этот лист тоже, наверно, стоит приложить... Как минимум те данные, которые используются в формулах. Если там есть что-то секретное, то поменяйте данные на что-то аналогичное и менее секретное... Постарайтесь сделать так, чтобы в примере не осталось ссылок на внешние файлы.
Изменено: Ренат - 06.06.2016 18:39:50 (уточнение по "персональным/коммерческим данным".)
Успехов. И мне того же. Благодарю. :)
 
 
 
#5
07.06.2016 11:59:29
Ренат, спасибо за отзывчивость,  выложил содержание папки бланков для примера
 
 
 
#6
07.06.2016 12:04:42
welsher, размер превышен... См. пункт 2.3 правил ("общим весом..."). Поправьте, иначе модераторы удалят вложение(я).
Достаточно было добавить вкладку из первого файла ("000001.xlsx") в "Реестр бланков.xlsm", либо одного файла... Смотрю...
Изменено: Ренат - 07.06.2016 12:11:24
Успехов. И мне того же. Благодарю. :)
 
 
 
#7
07.06.2016 13:31:12
Как то так:
Код
Sub Blanki()

Dim i As Long, j As Integer, k As String
Dim di As String, fn As String, Sel As String
ThisWorkbook.Sheets("Данные").Select
Sel = Selection.Address  ' запоминаем текущее выделение
i = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row ' последняя строка на листе
j = Cells.Find("*", [A1], , , xlByColumns, xlPrevious).Column ' последний столбец на листе
di = Cells(2, 1).Value

k = Cells(i, 2).Value
fn = Dir(di & k & ".xlsx")
Application.EnableEvents = False ' отключение событий - "для отключение макроса изменения листа"
While fn = k & ".xlsx" And k <> ""
    Range(Cells(1, 4), Cells(1, j)).Copy ' копируем "шаблон" формул
    Range(Cells(i, 4), Cells(i, j)).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Rows(i).Replace what:="000001", Replacement:=k ' "приводим шаблон" к нужному результату
    Rows(i).EntireRow.AutoFit
    Cells(i, 3).Hyperlinks.Add Anchor:=Cells(i, 3), Address:=di & k & ".xlsx"
    If i < Cells.Rows.Count Then ' если ещё есть куда протягивать (мало ли) :)
        Range(Cells(i, 1), Cells(i, j)).AutoFill Destination:=Range(Cells(i, 1), _
            Cells(i + 1, j)), Type:=xlFillDefault ' протягивание последней строки
        i = i + 1
        k = Cells(i, 2).Value
        fn = Dir(di & k & ".xlsx")
    Else
        k = ""
    End If
Wend
If fn <> k & ".xlsx" Then Rows(i).Delete ' удаление строки с несуществующим бланком
Range(Sel).Select ' восстанавливаем исходное выделение
Application.EnableEvents = True

End Sub
Только этот код надо записать в основной модуль (не в модуль листа) и "повесить на кнопку". Плюс надо удалить "старый код" из модуля листа. Код будет добавлять строки к самой нижней строке, поэтому на листе не должно быть строк с пустыми данными (т.е. если бланков 5, то и строк данными должно быть 5, без строк с формулами "на будущее").
Успехов. И мне того же. Благодарю. :)
 
 
 
#8
07.06.2016 16:48:02
Ренат, огромное спасибо!! все работает,   плюсов тебе в карму больших=)
 
 
 
#9
09.04.2019 09:23:26
.
Изменено: NikZav - 12.04.2019 09:21:33
 
 
 
Страницы: 1
Наверх