MergeWorkbooks - значения, найденные в двадцать первой ячейке отсюда

Question

У меня есть этот код. Он работает правильно, создает новый лист, копирует и вставляет значения, найденные в C10, A11, A16, C16, D16 и т. Д. c в соответствующих столбцах. Но мне нужно, чтобы, не переходя к следующему файлу каталога, я также копировал все значения, которые он находит в ячейке C31, A32, A37, C37, D37, а также значения в ячейке C52, A53, A58, C58, D58 и также значения в ячейках C73, A74, A79, C79, D59. Короче говоря, мы поняли друг друга: значения найдены на двадцать первой клетке отсюда. Пока есть какая-то ценность. Я попытался с решением, но, видимо, это было не правильно. Кто может это сделать?

Option Explicit

Sub MergeCode1()
    Dim BaseWks As Worksheet
    Dim rnum As Long
    Dim MySplit As Variant
    Dim Mybook As Workbook
    Dim src1 As Range, src2 As Range, src3 As Range, src4 As Range, src5 As Range, src6 As Range, src7 As Range, src8 As Range, src9 As Range, src10 As Range, src11 As Range
    Dim destrange As Range
    Dim Rcount As Long
    Dim f

    'Add a new workbook with one sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    BaseWks.Range("A1").Font.Size = 36
    BaseWks.Range("A1").Value = "Please Wait"
    rnum = 3

    MyFiles = ""
    Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=0, _
                          FileFilterOption:=0, FileNameFilterStr:="")

    If MyFiles <> "" Then

        MySplit = Split(MyFiles, Chr(13))
        For Each f In MySplit

            Set Mybook = Workbooks.Open(f)
            Set src1 = Mybook.Worksheets(1).Range("C10:C14")
            Set src2 = Mybook.Worksheets(1).Range("A11")
            Set src3 = Mybook.Worksheets(1).Range("A16")
            Set src4 = Mybook.Worksheets(1).Range("C16")
            Set src5 = Mybook.Worksheets(1).Range("D16")
            Set src6 = Mybook.Worksheets(1).Range("E16")
            Set src7 = Mybook.Worksheets(1).Range("D17")
            Set src8 = Mybook.Worksheets(1).Range("E17")
            Set src9 = Mybook.Worksheets(1).Range("D18")
            Set src10 = Mybook.Worksheets(1).Range("D19")
            Set src11 = Mybook.Worksheets(1).Range("D20")
            'max # of rows to be added...
            Rcount = Application.Max(src1.Rows.Count, src2.Rows.Count, src3.Rows.Count, src4.Rows.Count, src5.Rows.Count, src6.Rows.Count, src7.Rows.Count, src8.Rows.Count, src9.Rows.Count, src10.Rows.Count, src11.Rows.Count)

            If rnum + Rcount >= BaseWks.Rows.Count Then
                MsgBox "Sorry there are not enough rows in the sheet"
                Mybook.Close savechanges:=False
                Exit For
            Else

            BaseWks.Cells(Rnum, "A").Value = f

            BaseWks.Cells(Rnum, "B").Resize(src1.Rows.Count, _
                                            src1.Columns.Count).Value = src1.Value
            'BaseWks.Cells(Rnum, "B").Offset(0, src1.Columns.Count) _
                         .Resize(src1.Rows.Count, src1.Columns.Count).Value = src1.Value

            BaseWks.Cells(Rnum, "C").Value = src2.Value

            BaseWks.Cells(Rnum, "D").Value = src3.Value
            'BaseWks.Cells(Rnum, "D").Offset(0, src3.Columns.Count) _
                         .Resize(src3.Rows.Count, src3.Columns.Count).Value = src3.Value

            BaseWks.Cells(Rnum, "E").Resize(src4.Rows.Count, _
                                            src4.Columns.Count).Value = src4.Value
            BaseWks.Cells(Rnum, "E").Offset(0, src4.Columns.Count) _
                         .Resize(src4.Rows.Count, src4.Columns.Count).Value = src4.Value

                BaseWks.Cells(rnum, "F").Resize(src5.Rows.Count, _
                                                src5.Columns.Count).Value = src5.Value
                BaseWks.Cells(rnum, "F").Offset(0, src5.Columns.Count) _
                             .Resize(src5.Rows.Count, src5.Columns.Count).Value = src5.Value

                BaseWks.Cells(rnum, "G").Resize(src6.Rows.Count, _
                                                src6.Columns.Count).Value = src6.Value
                BaseWks.Cells(rnum, "G").Offset(0, src6.Columns.Count) _
                             .Resize(src6.Rows.Count, src6.Columns.Count).Value = src6.Value

                BaseWks.Cells(rnum, "H").Resize(src7.Rows.Count, _
                                                src7.Columns.Count).Value = src7.Value
                BaseWks.Cells(rnum, "H").Offset(0, src7.Columns.Count) _
                             .Resize(src7.Rows.Count, src7.Columns.Count).Value = src7.Value

                BaseWks.Cells(rnum, "I").Resize(src8.Rows.Count, _
                                                src8.Columns.Count).Value = src8.Value
                BaseWks.Cells(rnum, "I").Offset(0, src8.Columns.Count) _
                             .Resize(src8.Rows.Count, src8.Columns.Count).Value = src8.Value

                BaseWks.Cells(rnum, "J").Resize(src9.Rows.Count, _
                                                src9.Columns.Count).Value = src9.Value
                BaseWks.Cells(rnum, "J").Offset(0, src9.Columns.Count) _
                             .Resize(src9.Rows.Count, src9.Columns.Count).Value = src9.Value

                BaseWks.Cells(rnum, "K").Resize(src10.Rows.Count, _
                                                src10.Columns.Count).Value = src10.Value
                BaseWks.Cells(rnum, "K").Offset(0, src10.Columns.Count) _
                             .Resize(src10.Rows.Count, src10.Columns.Count).Value = src10.Value

                BaseWks.Cells(rnum, "L").Resize(src11.Rows.Count, _
                                                src11.Columns.Count).Value = src11.Value
                BaseWks.Cells(rnum, "L").Offset(0, src11.Columns.Count) _
                             .Resize(src11.Rows.Count, src11.Columns.Count).Value = src11.Value

                rnum = rnum + Rcount

            End If

            Mybook.Close savechanges:=False
        Next f
        BaseWks.Columns.AutoFit

    End If

    BaseWks.Range("A1").Value = "Ready"

End Sub

Спасибо

Answer 1

Не проверено:

Sub MergeCode1()
    Const ROW_OFFSET As Long = 21
    Dim BaseWks As Worksheet
    Dim rnum As Long
    Dim MySplit As Variant
    Dim Mybook As Workbook
    Dim rngSrc As Range
    Dim destrange As Range
    Dim Rcount As Long
    Dim f, arrSources, src, rOffset As Long, wsSrc As Worksheet, col As Long
    Dim hadValues As Boolean

    'Add a new workbook with one sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    BaseWks.Range("A1").Font.Size = 36
    BaseWks.Range("A1").Value = "Please Wait"
    rnum = 3

    MyFiles = ""
    Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=0, _
                          FileFilterOption:=0, FileNameFilterStr:="")

    If MyFiles <> "" Then

        'list of all the ranges to be copied
        arrSources = Array("C10:C14", "A11", "A16", "C16", "D16", _
                           "E16", "D17", "E17", "D18", "D19", "D20")
        Rcount = maxRows(BaseWks, arrSources) 'max rows for all addresses in arrSources

        MySplit = Split(MyFiles, Chr(13))
        For Each f In MySplit

            Set Mybook = Workbooks.Open(f)
            Set wsSrc = Mybook.Worksheets(1)

            rOffset = 0

            Do
                If rnum + Rcount >= BaseWks.Rows.Count Then
                    MsgBox "Sorry there are not enough rows in the sheet"
                    Mybook.Close savechanges:=False
                    Exit Sub 'nothing more to do...
                End If

                BaseWks.Cells(rnum, "A").Value = f
                col = 2
                hadValues = False 'flag for if there were any values copied
                For Each src In arrSources
                    With wsSrc.Range(src).Offset(rOffset, 0)
                        If Application.CountA(.Cells) > 0 Then hadValues = True 'any data?
                        BaseWks.Cells(rnum, col).Resize(.Rows.Count, _
                                                        .Columns.Count).Value = .Value
                        col = col + .Columns.Count 'set up next destination column
                    End With
                Next src
                If Not hadValues Then
                    'nothing copied: exit for this file
                    Exit Do
                Else
                    'still have data:keep going to next block
                    rnum = rnum + Rcount
                    rOffset = rOffset + ROW_OFFSET
                End If
            Loop

            Mybook.Close savechanges:=False

        Next f
        BaseWks.Columns.AutoFit

    End If

    BaseWks.Range("A1").Value = "Ready"

End Sub

'find the max rows for any range address in arr
Function maxRows(ws As Worksheet, arr)
    Dim rv As Long, e
    For Each e In arr
        rv = Application.Max(rv, ws.Range(e).Rows.Count)
    Next e
    maxRows = rv
End Function