Question

我有一个excel vba问题，我试图解决，在搜索互联网和许多论坛后，我没有成功。

问题1：如果a2中的单元格表示Brian Johnson（甚至是BrianJohnson），是否可以打开文件BrianJohnson.xlsx？我想要打开大约30个文件，这样主文件可以在其他工作表中使用单元格引用，事情不会变得棘手。

        Sub aaron_gather()
'
' aaron_gather Macro
Dim bestandopen
Application.ScreenUpdating = False
On Error Resume Next 'if there are no 12 sheets
 bestandopen = Dir("H:\Americorps\*")
    Do Until bestandopen = ""
      If bestandopen = "" Then Exit Do
       If Not bestandopen = "Americorps Master Sheet 1.xlsm" Then
        Workbooks.Open "H:\Americorps\" & bestandopen
    ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1) = ActiveWorkbook.Name
         For i = 1 To 12
          ThisWorkbook.Sheets("Total Hours").Cells(Rows.Count, 1).End(xlUp).Offset(, i) = ActiveWorkbook.Sheets(i).Range("E43")
         Next i
       ThisWorkbook.Sheets("Total Hours").Columns.AutoFit
    Workbooks(bestandopen).Close
 End If
      bestandopen = Dir
    Loop
End Sub

Answer 1

已编译但未经过测试......

Sub Test()

Const FLDR_PATH As String = "H:\Americorps\"
Dim c As Range, wbSource As Workbook
Dim shtTH As Worksheet, i As Integer
Dim cellTH As Range, filepath As String

    Set shtTH = ThisWorkbook.Sheets("Total Hours")

    For Each c In shtTH.Range("A2:A10") 'are names on total hours sheet?

        filepath = FLDR_PATH & Replace(c.Value, " ", "") & ".xlsx"

        If Len(Dir(filepath, vbNormal)) > 0 Then
            c.Font.ColorIndex = xlAutomatic
            Set wbSource = Workbooks.Open(filepath, , True) 'readonly

            For i = 1 To 12
                'copy values to same row as filename source
                c.Offset(0, i).Value = _
                    wbSource.Sheets(i).Range("E43").Value
            Next i

            wbSource.Close False
        Else
            c.Font.Color = vbRed 'file not found
        End If

    Next c

End Sub

VBA代码，用于查找文件夹中的文件组，始终按相同顺序排列，并将特定单元格粘贴到主文件中

1 个答案: