Copying non-adjacent cells in each row of a dynamic range selection using the Union function

[dbaruzzini]

Hello, and thank you in advance for any guidance you are willing to offer.

Basic Info: Excel 2013; SharePoint 2013; Windows Enterprise

I have a lot of things going on with this code since the material I wish to copy is located in a drive, mapped to a SharePoint library. The range I wish to copy is dynamic based on how many rows of data there are in each workbook. The code I have displayed below is actually a sub procedure I have called to another.

The code works beautifully except for one part... The last two non-adjacent cells (.cells(rw, 39) & .cells(rw, 44)) do not copy correctly. I get an #N/A error for both. I am open to ideas. Ideally, I would love to include the objFile.Path also into the Union function but it will not accept it due to the fact that it's not a range.

Here is the code:

Public Sub GetAllFilesFolders(Objfolder As Object, SharepointAddress As String)
    Dim objFile As Object
    Dim wkbk As Workbook
    Dim startrow As Long
    Dim endrow As Long
    Dim TWB As ThisWorkbook: Set TWB = ThisWorkbook
    Dim rw As Long
    Dim Row As Long
    Dim TWRG As Range
  
Application.ScreenUpdating = False
    Set TWRG = TWB.Sheets(1).[A1]
    For Each objFile In Objfolder.Files
        Set wkbk = Workbooks.Open(objFile.Path, False, True, IgnoreReadOnlyRecommended:=True)
DoEvents
            With wkbk.Sheets(1)
                startrow = 8
                endrow = .Cells(.Rows.Count, 1).End(xlUp).Row
                    For rw = startrow To endrow
                            TWRG.Offset(1, 0) = objFile.Path
                            TWRG.Offset(1, 1).Resize(1, 10) = _
                            Union(.Cells(rw, 1), .Cells(rw, 2), .Cells(rw, 3), _
                            .Cells(rw, 4), .Cells(rw, 5), .Cells(rw, 6), _
                            .Cells(rw, 7), .Cells(rw, 8), .Cells(rw, 39), .Cells(rw, 44)).Value
                    Set TWRG = TWRG.Offset(1, 0)
DoEvents
                    Next rw
            End With
        wkbk.Close False
DoEvents
    Next
Application.ScreenUpdating = True
End Sub

 

[pgc01]

                        TWRG.Offset(1, 1).Resize(1, 10) = _
                            Union(.Cells(rw, 1), .Cells(rw, 2), .Cells(rw, 3), _
                            .Cells(rw, 4), .Cells(rw, 5), .Cells(rw, 6), _
                            .Cells(rw, 7), .Cells(rw, 8), .Cells(rw, 39), .Cells(rw, 44)).Value

This would only work if the union had just contiguous cells.

Try instead:

    TWRG.Offset(1, 1).Resize(1, 8).Value = .Cells(rw, 1).Resize(1, 8).Value
    TWRG.Offset(1, 9).Value = .Cells(rw, 39).Value
    TWRG.Offset(1, 10).Value = .Cells(rw, 44).Value

 

[dbaruzzini]

Agreed. I did make this change exactly; a quick fix and it works. I was just looking for a way to do it using one line of code. I think that the resize method doesn't allow me to bring non-contiguous cells over. Maybe if I referenced my range in some other way without the resize method, it would work. I'll have to experiment. Thanks for replying

 

[Rick Rothstein]

Public Sub GetAllFilesFolders(Objfolder As Object, SharepointAddress As String)
    Dim objFile As Object
    Dim wkbk As Workbook
    Dim startrow As Long
    Dim endrow As Long
    Dim TWB As ThisWorkbook: Set TWB = ThisWorkbook
    Dim rw As Long
    Dim Row As Long
    Dim TWRG As Range
  
Application.ScreenUpdating = False
    Set TWRG = TWB.Sheets(1).[A1]
    For Each objFile In Objfolder.Files
        Set wkbk = Workbooks.Open(objFile.Path, False, True, IgnoreReadOnlyRecommended:=True)
DoEvents
            With wkbk.Sheets(1)
                startrow = 8
                endrow = .Cells(.Rows.Count, 1).End(xlUp).Row
                    For rw = startrow To endrow
                            TWRG.Offset(1, 0) = objFile.Path
                            TWRG.Offset(1, 1).Resize(1, 10) = _
                            Union(.Cells(rw, 1), .Cells(rw, 2), .Cells(rw, 3), _
                            .Cells(rw, 4), .Cells(rw, 5), .Cells(rw, 6), _
                            .Cells(rw, 7), .Cells(rw, 8), .Cells(rw, 39), .Cells(rw, 44)).Value
                    Set TWRG = TWRG.Offset(1, 0)
DoEvents
                    Next rw
            End With
        wkbk.Close False
DoEvents
    Next
Application.ScreenUpdating = True
End Sub

Does replacing the red highlighted line of code with the following work for you...

Intersect(.Rows(rw), .Range("A:H,AM:AM,AR:AR")).Copy TWRG.Offset(1, 1)

 

[pgc01]

If you define a range with non-contiguous cells you'll be creating a multi-area range and if you use it directly in an assignment you'll only get the values of the first area.

 

[dbaruzzini]

It's funny Rick- I made a decision to avoid the copy-paste method right from the start and wouldn't you know, therein lies the solution I was looking for. A lesson learned to never count anything out and to stay "open". I have not worked with the intersect method yet; I just haven't spent the time studying it to know how to use it properly. This definitely light a fire for me to begin that endeavor. Thank you very much for the solution!

 

[dbaruzzini]

Thank you again pgc01. You've given me great explanation and now understand my errors. Everyone on this site is so helpful. Thanks again!!