Question

我是VBA的新手而且没有写这个代码，归功于Ron de Bruin。我使用它来从我选择的任何文件中输入到Range - 第12行的任何单元格中检索值。它适用于单元格位置，但我的所有文件都有不同的位置用于定义的名称。但是当我将一个定义的名称放入范围时，即。设置rng = Range（＆＃34; cName1＆＃34;）它不起作用。所以基本上我将如何修改它以便我可以放入一个命名区域（如果可能的话也可以使用单元格位置...）提前感谢您的帮助!!

Sub Summary_cells_from_Different_Workbooks_1()
    Dim FileNameXls As Variant
    Dim SummWks As Worksheet
    Dim ColNum As Integer
    Dim myCell As Range, Rng As Range
    Dim RwNum As Long, FNum As Long, FinalSlash As Long
    Dim ShName As String, PathStr As String
    Dim SheetCheck As String, JustFileName As String
    Dim JustFolder As String

    ShName = "Sheet1"  '<---- Change
    Set Rng = Range("D4:D20")   '<---- Change

    'Select the files with GetOpenFilename
    FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", _
                                          MultiSelect:=True)

     If IsArray(FileNameXls) = False Then
        'do nothing
     Else
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
        End With

        'Add a new workbook with one sheet for the Summary
        Set SummWks = Workbooks.Add(1).Worksheets(1)

        'The links to the first workbook will start in row 2
        RwNum = 1

        For FNum = LBound(FileNameXls) To UBound(FileNameXls)
            ColNum = 1
            RwNum = RwNum + 1
            FinalSlash = InStrRev(FileNameXls(FNum), "\")
            JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
            JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

            'copy the workbook name in column A
            SummWks.Cells(RwNum, 1).Value = JustFileName

            'build the formula string
            JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''")
            PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

            On Error Resume Next
            SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
            If Err.Number <> 0 Then
                'If the sheet not exist in the workbook the row color will be Yellow.
                SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
                    .Interior.Color = vbYellow
            Else
                For Each myCell In Rng.Cells
                    ColNum = ColNum + 1
                    SummWks.Cells(RwNum, ColNum).Formula = _
                    "=" & PathStr & myCell.Address
                Next myCell
            End If
            On Error GoTo 0
        Next FNum

        ' Use AutoFit to set the column width in the new workbook
        SummWks.UsedRange.Columns.AutoFit

        MsgBox "The Summary is ready, save the file if you want to keep it"

        With Application
            .Calculation = xlCalculationAutomatic
            .ScreenUpdating = True
        End With
    End If
End Sub

为什么此代码不适用于命名范围？

0 个答案: