Страницы: 1
RSS
VBA копирование активного диапазона из одной книги и вставка в активный лист другой книги с сохранением формата
 
Добрый день! Я новичок в vba, если нетрудно, просьба помочь дополнить и поправить ранее написанного vba.
Суть в том, что есть файлы из которых нужно копировать информацию, при этом чтобы после клика на ячейку выбрался активный диапазон и скопировался(это работает), надо внедрить, чтобы копировал с листа, где активный диапазон,  имя листа может быть разное. Потом необходимо выбрать ячейку (может быть любая), куда вставится путь и название файла из которого копируется (это работает). Далее нужно вставить данные, которые копировались из активного диапазона (это работает), но формат меняется, а надо сохранить формат. А ещё надо протянуть (заполнить) автоматом ячейку, где есть название пути,  на длину столбца равняться, где есть вставляемые данные, а потом надо вниз на следующую строку вниз ячейку В спуститься, чтобы дальше также запускать и данные вставлять:

Sub CopyPaste()Dim avFiles
   avFiles = Application.GetOpenFilename("Excel files(*.xls*), *.xls*", 1, "Выбрать", , True)
If VarType(avFiles) = vbBoolean Then
'Нажата отмена'
Exit Sub
End If


'Открываем файл, копируем данные и закрываем
Workbooks.Open Filename:=avFiles(1)


Dim Rng, Rng1 As Range


On Error Resume Next
Set Rng = Application.InputBox("Укажите мышкой на нужную ячейку", "Выберите ячейку", , , , , , 8)
If Rng Is Nothing Then
MsgBox "Вы не выбрали ячейку!", 48, "Ошибка"
Exit Sub
End If
On Error GoTo 0


Range(Rng.Address).Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
ActiveWorkbook.Close


'выбираем ячейку для вставки пути
On Error Resume Next
Set Rng1 = Application.InputBox("Укажите мышкой на нужную ячейку", "Выберите ячейку", , , , , , 8)
If Rng1 Is Nothing Then
MsgBox "Вы не выбрали ячейку!", 48, "Ошибка"
Exit Sub
End If
On Error GoTo 0


'вставляем путь файла
Range(Rng1.Address).Value = avFiles(1)


'В открытый файл вставляем данные
ActiveSheet.Paste


End Sub
 
Код
Sub CopyPaste()

Dim wbActiveWorkbook As Workbook
Set wbActiveWorkbook = ActiveWorkbook

Dim avFiles
   avFiles = Application.GetOpenFilename("Excel files(*.xls*), *.xls*", 1, "Выбрать", , True)
If VarType(avFiles) = vbBoolean Then
'Нажата отмена'
Exit Sub
End If


'Открываем файл, копируем данные и закрываем
Workbooks.Open Filename:=avFiles(1)


Dim Rng, Rng1 As Range


On Error Resume Next
Set Rng = Application.InputBox("Укажите мышкой на нужную ячейку", "Выберите ячейку", , , , , , 8)
If Rng Is Nothing Then
MsgBox "Вы не выбрали ячейку!", 48, "Ошибка"
Exit Sub
End If
On Error GoTo 0

Dim r1 As Range

Range(Rng.Address).Select
Set r1 = Range(Selection, ActiveCell.SpecialCells(xlLastCell)) '.Select
'Selection.Copy
'ActiveWorkbook.Close
wbActiveWorkbook.Activate

'выбираем ячейку для вставки пути
On Error Resume Next
Set Rng1 = Application.InputBox("Укажите мышкой на нужную ячейку", "Выберите ячейку", , , , , , 8)
If Rng1 Is Nothing Then
MsgBox "Вы не выбрали ячейку!", 48, "Ошибка"
Exit Sub
End If
On Error GoTo 0


'вставляем путь файла
Range(Rng1.Address).Value = avFiles(1)


'В открытый файл вставляем данные
'ActiveSheet.Paste

r1.Copy Rng1
r1.Parent.Parent.Close False

End Sub
 
Сейчас не вставляет путь в указанную ячейку, как будто игнорирует, вставляет в ячейку А, когда ставишь на В данные вставить, а в А путь. Но ячейки могут быть разные, поэтому и стоит их выбор. И вниз всё-таки не опускается после вставки🙈. А форматы правильно вставляет спасибо)
Изменено: Loule - 30.05.2022 17:41:34
 
Цитата
написал:
не опускается после вставки
Речь всё ещё про Excel? )
Код
Sub CopyPaste()
 
Dim wbActiveWorkbook As Workbook
Set wbActiveWorkbook = ActiveWorkbook
 
Dim avFiles
   avFiles = Application.GetOpenFilename("Excel files(*.xls*), *.xls*", 1, "Выбрать", , True)
If VarType(avFiles) = vbBoolean Then
'Нажата отмена'
Exit Sub
End If
 
 
'Открываем файл, копируем данные и закрываем
Workbooks.Open Filename:=avFiles(1)
 
 
Dim Rng, Rng1 As Range
 
 
On Error Resume Next
Set Rng = Application.InputBox("Укажите мышкой на нужную ячейку", "Выберите ячейку", , , , , , 8)
If Rng Is Nothing Then
MsgBox "Вы не выбрали ячейку!", 48, "Ошибка"
Exit Sub
End If
On Error GoTo 0
 
Dim r1 As Range
 
Range(Rng.Address).Select
Set r1 = Range(Selection, ActiveCell.SpecialCells(xlLastCell)) '.Select
'Selection.Copy
'ActiveWorkbook.Close
wbActiveWorkbook.Activate
 
'выбираем ячейку для вставки пути
On Error Resume Next
Set Rng1 = Application.InputBox("Укажите мышкой на нужную ячейку", "Выберите ячейку", , , , , , 8)
If Rng1 Is Nothing Then
MsgBox "Вы не выбрали ячейку!", 48, "Ошибка"
Exit Sub
End If
On Error GoTo 0
 
 

'В открытый файл вставляем данные
'ActiveSheet.Paste
 
r1.Copy Rng1
'вставляем путь файла
Range(Rng1.Address).Columns(r1.Columns.Count + 1).Resize(r1.Rows.Count).Value = avFiles(1)
Range(Rng1.Address).Cells(r1.Rows.Count + 1, 1).Select
r1.Parent.Parent.Close False
 
End Sub
Страницы: 1
Наверх