VBA实现：将目录下XLSX文件指定数据精准复制到目标文件

以下是一个用VBA代码实现上述操作的示例： ```vba Sub CopyDataToA() Dim path As String Dim aWorkbook As Workbook Dim aSheet As Worksheet Dim aRange As Range ' 设置a文件路径 path = "C:\path\to\a.xlsx" ' 打开a文件 Set aWorkbook = Workbooks.Open(path) Set aSheet = aWorkbook.Sheets(1) ' 获取a文件中的匹配范围 Set aRange = aSheet.Range("A2:A604") ' 遍历目录内的所有xlsx文件 Dim file As Variant Dim wb As Workbook Dim ws As Worksheet For Each file In Dir("C:\path\to\directory\*.xlsx") ' 打开文件 Set wb = Workbooks.Open("C:\path\to\directory\" & file) Set ws = wb.Sheets(1) ' 匹配成功则复制数据 If Not Application.Intersect(ws.Range("A2:A604"), aRange) Is Nothing Then ' 复制'h17'单元格到'd2:d604' ws.Range("H17").Copy Destination:=aSheet.Range("D2:D604").Find(what:=file).Offset(0, 1) ' 复制'b19'单元格到'e2:e604' ws.Range("B19").Copy Destination:=aSheet.Range("E2:E604").Find(what:=file).Offset(0, 1) ' 检查重复数据并复制至对应位置 Dim i As Integer Dim cell As Range For i = 3 To 25 Step 3 For Each cell In ws.Range("C8:Y8") If cell.Value = ws.Range("B19").Value Then Dim matchCell As Range Set matchCell = aSheet.Range("A2:A604").Find(what:=file) matchCell.Offset(0, i / 3 + 2).Value = ws.Cells(5, cell.Column).Value End If Next cell Next i End If ' 关闭打开的文件 wb.Close savechanges:=False Next file ' 关闭a文件并保存 aWorkbook.Close savechanges:=True End Sub ``` 请根据实际情况调整文件路径和匹配范围等参数，并确保在运行代码之前将所有目标文件和a文件保存。执行此代码后，将会将目录内的所有xlsx文件的指定数据复制到a文件中。 ######[AI写代码神器 | 1339点数解答 | 2024-06-21 13:46:32]