Почему этот код не работает с именованным диапазоном?

Я новичок VBA и не написал этот код, кредит переходит к Рон де Брюин. Я использую его для извлечения значения из тех ячеек, которые я ввожу в диапазон 12, из любых выбранных файлов. Он работает с ячейками, но все мои файлы имеют разные места для определенных имен. Но когда я помещаю определенное имя в диапазон, т.е. Установите rng = Range("cName1"), это не работает. Так что, в основном, как бы я изменил его, чтобы я мог поместить именованный диапазон (но также работает с расположением ячейки, если это возможно...) Заранее спасибо за любую помощь!!

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 ответов

Другие вопросы по тегам