在执行检查时将数据从一个工作簿复制到另一个工作簿

Question

对 VBA 来说是全新的。但这是我的代码。第一个代码框是检查 Workbook1 中的单元格 X 是否等于 Workbook2 中的单元格 Y，如果成功，它将继续到我的第二个代码框，它将从指定单元格中提取数据，然后将其粘贴到活动所在的行中单元格当前位于。第二个代码框需要大修以将粘贴功能指定到活动行中，从活动单元格开始。

我在尝试获取活动单元格当前所在的行时出错。

这是流程..

1. 命令按钮单击

2. 选择要从中复制数据的文件（此工作簿具有静态单元格，因此无论使用哪个电子表格，都会从同一单元格中提取数据）

3. 检查工作簿 1 进程号（静态单元格）是否与活动单元格所在的当前行中的工作簿 2 中的进程号匹配（同一列，更改行）

   4a。成功 - 继续将数据复制并粘贴到从活动单元格开始的活动行中

   4b。失败 - 错误消息，请勿复制或粘贴。

代码：

Sub Foo()
 Dim vFile As Variant
 Dim wbCopyTo As Workbook
 Dim wsCopyTo As Worksheet
 Dim wbCopyFrom As Workbook
 Dim wsCopyFrom As Worksheet

 Set wbCopyTo = ActiveWorkbook
 Set wsCopyTo = ActiveSheet

     '-------------------------------------------------------------
     'Open file with data to be copied

     vFile = Application.GetOpenFilename("Excel Files (*.xl*)," & _
     "*.xl*", 1, "Select Excel File", "Open", False)

     'If Cancel then Exit
     If TypeName(vFile) = "Boolean" Then
         Exit Sub
     Else
     Set wbCopyFrom = Workbooks.Open(vFile)
     Set wsCopyFrom = wbCopyFrom.Worksheets(1)
     End If

'Process number check to see if values match and the data is being put in the correct row

Dim projectNumber As Long
Dim column As Integer  
Dim row As Integer
Dim rng As Range

'Set column and row to whatever row/column contains the Project Number in wsCopyFrom (could also use Range if its a particular cell)
projectNumber = wsCopyFrom.Range("G5).Value

Set rng = wsCopyTo.Cells.EntireRow.Select 'Get selected row in Active Worksheet
For Each c In rng.Cells    ' Check each cell in row/range
    If c.Value = projectNumber   ' Project number was found
        MsgBox("Project number found!")

        ' Insert copy and pasting code here.... See below code box

    End If
Next c

' Project number was not found in selected range if you get to this point
 MsgBox("Project Number Does Not Match")


'Close file that was opened
     wbCopyFrom.Close SaveChanges:=False

代码：

'Copy and Pasting

 wsCopyFrom.Range("F21").Copy
 wsCopyTo.Range("Active Row, beginning at Active Cell").PasteSpecial Paste:=xlPasteValues, _
         Operation:=xlNone, SkipBlanks:=False, Transpose:=False

 wsCopyFrom.Range("G21").Copy
 wsCopyTo.Range("Active Row and Offset one column to the right from previous cell").PasteSpecial Paste:=xlPasteValues, _
         Operation:=xlNone, SkipBlanks:=False, Transpose:=False

 wsCopyFrom.Range("L21").Copy
 wsCopyTo.Range("Active Row and Offset one column to the right from previous cell").PasteSpecial Paste:=xlPasteValues, _
         Operation:=xlNone, SkipBlanks:=False, Transpose:=False

 wsCopyFrom.Range("M21").Copy
 wsCopyTo.Range("Active Row and Offset one column to the right from previous cell").PasteSpecial Paste:=xlPasteValues, _
         Operation:=xlNone, SkipBlanks:=False, Transpose:=False

 wsCopyFrom.Range("R21").Copy
 wsCopyTo.Range("Active Row and Offset one column to the right from previous cell").PasteSpecial Paste:=xlPasteValues, _
         Operation:=xlNone, SkipBlanks:=False, Transpose:=False

 wsCopyFrom.Range("S21").Copy
 wsCopyTo.Range("Active Row and Offset one column to the right from previous cell").PasteSpecial Paste:=xlPasteValues, _
         Operation:=xlNone, SkipBlanks:=False, Transpose:=False

 wsCopyFrom.Range("G31").Copy
 wsCopyTo.Range("Active Row and Offset one column to the right from previous cell").PasteSpecial Paste:=xlPasteValues, _
         Operation:=xlNone, SkipBlanks:=False, Transpose:=False

 wsCopyFrom.Range("M31").Copy
 wsCopyTo.Range(""Active Row and Offset one column to the right from previous cell).PasteSpecial Paste:=xlPasteValues, _
         Operation:=xlNone, SkipBlanks:=False, Transpose:=False

 wsCopyFrom.Range("S31").Copy
 wsCopyTo.Range("Active Row and Offset one column to the right from previous cell").PasteSpecial Paste:=xlPasteValues, _
         Operation:=xlNone, SkipBlanks:=False, Transpose:=False

 wsCopyFrom.Range("F41").Copy
 wsCopyTo.Range(""Active Row and Offset one column to the right from previous cell).PasteSpecial Paste:=xlPasteValues, _
         Operation:=xlNone, SkipBlanks:=False, Transpose:=False

 wsCopyFrom.Range("G41").Copy
 wsCopyTo.Range("Active Row and Offset one column to the right from previous cell").PasteSpecial Paste:=xlPasteValues, _
         Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Answer 1

如果您想要从 1 个文件复制并将其粘贴到另一个文件而不将其粘贴到现有内容上，那么您应该选择 VBscript 而不是 excel。

下面的例子：

    strPathSrc = "C:\......" ' Source files folder
strMaskSrc = "*.csv" ' Source files filter mask can be any format
iSheetSrc = 3 ' Source sheet index or name sheet you want to copy
strPathDst = "C:\....xlsx" ' Destination file
iSheetDst = 1 ' Destination sheet index or name

Set objExcel = CreateObject("Excel.Application")
Set fso = CreateObject("Scripting.FileSystemObject")
objExcel.Visible = false
Set objWorkBookDst = objExcel.Workbooks.Open(strPathDst)
Set objSheetDst = objWorkBookDst.Sheets(iSheetDst)
Set objShellApp = CreateObject("Shell.Application")
Set objFolder = objShellApp.NameSpace(strPathSrc)
Set objItems = objFolder.Items()
objItems.Filter 64 + 128, strMaskSrc
objExcel.DisplayAlerts = False
For Each objItem In objItems
    Set objWorkBookSrc = objExcel.Workbooks.Open(objItem.Path)
    Set objSheetSrc = objWorkBookSrc.Sheets(iSheetSrc)
    GetUsedRange(objSheetSrc).Copy
    Set objUsedRangeDst = GetUsedRange(objSheetDst)
    iRowsCount = objUsedRangeDst.Rows.Count
    objWorkBookDst.Activate
    objSheetDst.Cells(iRowsCount + 1, 1).Select
    objSheetDst.Paste
    objWorkBookDst.Application.CutCopyMode = False
    objWorkBookSrc.Close

Next
objExcel.ActiveWorkbook.Save
fso.DeleteFile "C:......", True 'delete original file if required
Function GetUsedRange(objSheet)
    With objSheet
        Set GetUsedRange = .Range(.Cells(1, 1), .Cells(.UsedRange.Row + .UsedRange.Rows.Count - 1, .UsedRange.Column + .UsedRange.Columns.Count - 1))
    End With
End Function

将其粘贴到记事本中并将其另存为 .vbs 然后运行它，您应该会对其进行排序。如有必要，您甚至可以使用 Windows 调度程序自动执行此操作。

希望对你有帮助