Excel宏在工作簿之间复制和粘贴

时间：2018-11-29 10:26:48

标签： excel vba copy paste

因此，我遇到了有关使用宏从一个工作簿复制和粘贴到另一个工作簿的砖墙

我大约需要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 :(得分：1)

赞：

  1. 手动或使用（另一个）宏列出您需要复制的文件。例如，像这样的Get list of Excel files in a folder using 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

答案 1 :(得分：0)

遵循这些原则。假设您要沿着第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
相关问题
最新问题