MergeWorkbooks-在第21个单元格处找到的值

Question

我有此代码。它可以正常工作，创建新的工作表，然后将相应列中的C10，A11，A16，C16，D16等中的值复制粘贴。但是我需要，而无需转到下一个目录文件，我还要复制它在单元格C31，A32，A37，C37，D37中找到的所有值，以及在单元格C52，A53，A58，C58，D58和依此类推，C73，A74，A79，C79，D59单元格中的值也是如此。简而言之，我们彼此理解：在第21个单元格之外找到的值。只要有一定的价值。我尝试了一种解决方案，但显然这是不正确的。谁可以做？

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