根據單元格值從多個工作簿復制行

Question

如何根據單元格值從工作簿中復制單元格。

在需要填寫的excel文件中，B列包含可以找到數據的文件名的一部分。

B2 contains 312123-145

B3 contains 312123-195

etc, 

通常大約 18 行，但循環/步驟可以 go 直到找到一個空單元格

數據包含的工作簿是 cell-value.xlsm 在 312123-145.xlsm 中有一個名為 Yield 的工作表我想從該工作表中復制 A2:N2，並將該數據粘貼到主 excel 工作表中的列中E:R 在相應的行中。

我不知道如何開始查找單元格值並找到具有正確數據的文件，然后如何進入下一行。

這是我開始使用的代碼，我首先對所有單元格值進行了硬編碼以保持簡單。

Sub ImportWorksheet() 
    ' This macro will import a file into this workbook 
    Sheets("Sheet1").Select 
    PathName = "C:\Documents\test\"
    Filename = "312123-195" 
    TabName = "Yield"
    ControlFile = ActiveWorkbook.Name 
    Workbooks.Open Filename:=PathName & Filename 
    ActiveSheet.Name = TabName 
    Sheets(TabName).Copy After:=Workbooks(ControlFile).Sheets(1) 
    Windows(Filename).Activate 
    ActiveWorkbook.Close SaveChanges:=False 
    Windows(ControlFile).Activate 
End Sub

Answer 1

從已關閉的工作簿導入數據

Option Explicit

Sub ImportData()
    
    Dim sFolderPath As String: sFolderPath = "C:\Documents\test\"
    Dim sFileExtension As String: sFileExtension = ".xlsm" ' ".xls*"
    Const sName As String = "Yield"
    Const srgAddress As String = "A2:N2"
    Const sFileDelimiter As String = "-"
    
    Const dName As String = "Sheet1"
    Const dlCol As String = "B" ' Lookup
    Const dvCol As String = "E" ' Value
    Const dfRow As Long = 2
    
    If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
    If Left(sFileExtension, 1) <> "." Then sFileExtension = "." & sFileExtension
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    
    Dim dws As Worksheet: Set dws = dwb.Worksheets(dName)
    Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dlCol).End(xlUp).Row
    If dlRow < dfRow Then Exit Sub ' no data
    Dim dlrg As Range
    Set dlrg = dws.Range(dws.Cells(dfRow, dlCol), dws.Cells(dlRow, dlCol))
    Dim dcCount As Long: dcCount = dws.Range(srgAddress).Columns.Count
    Dim dvrg As Range: Set dvrg = dws.Cells(dfRow, dvCol).Resize(, dcCount)
    
    Dim swb As Workbook
    Dim sws As Worksheet
    Dim sFilePattern As String
    Dim sFileName As String
    Dim dlCell As Range
    Dim swsCount As Long
    
    Application.ScreenUpdating = False
    
    For Each dlCell In dlrg.Cells
        sFilePattern = sFolderPath & Left(CStr(dlCell.Value), _
            InStr(1, CStr(dlCell.Value), sFileDelimiter, vbTextCompare) - 1) _
            & sFileExtension
        sFileName = Dir(sFilePattern)
        If Len(sFileName) > 0 Then ' file (workbook) exists
            Set swb = Workbooks.Open(sFolderPath & sFileName)
            On Error Resume Next
                Set sws = swb.Worksheets(sName)
            On Error GoTo 0
            If Not sws Is Nothing Then ' worksheet exists
                dvrg.Value = sws.Range(srgAddress).Value
                swsCount = swsCount + 1
            End If
            swb.Close SaveChanges:=False
        End If
        Set dvrg = dvrg.Offset(1)
    Next dlCell
    
    Application.ScreenUpdating = True
    
    Select Case swsCount
    Case 0
        MsgBox "No data imported", vbCritical
    Case 1
        MsgBox "Data imported from one worksheet.", vbInformation
    Case Else
        MsgBox "Data imported from " & swsCount & " worksheets.", vbInformation
    End Select
    
End Sub