Макрос Excel для копирования и вставки между книгами - PullRequest
Новая
       14

Макрос Excel для копирования и вставки между книгами

0 голосов
/ 29 ноября 2018

Итак, я наткнулся на кирпичную стену о копировании и вставке из одной рабочей книги в другую с помощью макросов

У меня около 800 рабочих книг, из которых мне нужно скопировать определенные ячейки и вставить их в отдельную«Трекер» рабочая книга.Макросы будут самым простым способом сделать это.

Проблема, с которой я сталкиваюсь, заключается в том, как мне сказать макросу, что книга COPYFROM.XLSX будет меняться, и когда она будет вставлена, она должнавставить следующую строку, чтобы не перезаписывать информацию.

Любая помощь, которую вы, ребята, получите, будет очень полезна, спасибо. 

Windows("COPYFROM.xlsx").Activate
Range("E39:F39").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("B8").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("F13").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("C8").Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("C13").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("D8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("C15").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("E8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("F17").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("F8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("C17:C18").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("G8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("C27").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("H8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("F21").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("J8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("C21").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("K8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("C23").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("N8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("F25").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("O8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("C37").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("Q8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("F59").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("S8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("F61").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("T8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("F19").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("U8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("C31").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("V8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("F49").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("W8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("F31").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("X8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("F37").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("Y8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("F15").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("AA8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("C37").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("AE8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Windows("COPYFROM.xlsx").Activate
Range("F45").Select
Selection.Copy
Windows("Paste.XLSX").Activate
Range("AF8").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False



End Sub

Ответы [ 2 ]

0 голосов
/ 29 ноября 2018

Пример:

  1. Список файлов, которые необходимо скопировать, либо вручную, либо с помощью (другого) макроса.Например, как это Получить список файлов Excel в папке, используя VBA

  2. Используя этот список, установите диапазон для запуска через

  3. Скопируйте и вставьте данные в следующую свободную строку 

    Sub test()
Dim LastColumn As Long, LastRow As Long, LR As Long, n As Long
Dim Thiswb As Workbook, Openwb As Workbook
Dim Source As Worksheet, wsTO As Worksheet, wsM As Worksheet
Dim FileRange As Range
Dim sSource As String, FileName As String
Dim cell As Variant, FilePath As Variant
Set Thiswb = ThisWorkbook
' Here you put the list of the files you want to copy from
Set Source = Thiswb.Worksheets("Source")
' Here you will paste your data
Set wsTO = Thiswb.Worksheets("HereComesYourData")
' Find the last row of column A. The list of files to look for is in this column
LastRow = Source.Cells(Rows.Count, 1).End(xlUp).Row
'Set the range in which to look
Set FileRange = Source.Range(Source.Cells(2, 1), Source.Cells(LastRow, 1))
n = 2
On Error Resume Next
For Each cell In FileRange    'Run through the whole range
    'Error handling when file or worksheet isn't found
    FilePath = Source.Cells(n, 2).Value
    FileName = Source.Cells(n, 1).Value
    Workbooks.Open (FilePath)
    Set Openwb = Workbooks(FileName)
    'Depending on what you want to copy - declare the correct variable
    Set wsM = Openwb.Worksheets("Master")
    'Calculate last column number of source
    LastColumn = wsM.Cells(1, Columns.Count).End(xlToLeft).Column
    'Calculate last row number of source
    LastRow = wsM.Cells(Rows.Count, 1).End(xlUp).Row
    'Calculate last row number of destination
    LR = wsTO.Cells(Rows.Count, 1).End(xlUp).Row
    'Paste values
    wsTO.Range(wsTO.Cells(LR, 1), wsTO.Cells(LR + LastRow, LastColumn)).Value = wsM.Range(wsM.Cells(2, 1), wsM.Cells(LastRow, LastColumn)).Value
    Openwb.Close SaveChanges:=False
Next cell
End sub
0 голосов
/ 29 ноября 2018

Что-то в этом роде.Предполагая, что вы двигаетесь вдоль строки 8. Вы должны использовать имена листов, а не индексы ниже, и использовать более значимые имена процедур / переменных. 

Sub x()

Dim c As Long

Windows("COPYFROM.xlsx").Sheets(1).Range("E39:F39").Copy
With Windows("Paste.XLSX").Sheets(1)
    c = .Cells(8, Columns.Count).End(xlToLeft).Column + 1
    .Cells(8, c).PasteSpecial Paste:=xlPasteValues
End With

'etc

End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Похожие темы

...