Properly looping through non-contiguous ranges?

Question

I have a few non-contiguous ranges that may vary in size each time it is run. I would like to take each of the ranges and copy and paste them onto their own individual worksheets (one range per sheet).

My code currently works for the first range and sheet. After the second sheet is created, the ranges are highlighted, but the first range is again copied and pasted onto the second sheet, instead of the corresponding second range. Then, the third sheet is created, but again, only the first range is copied and pasted onto this sheet. I know something is wrong with my looping, but I can't figure out where.

I have exhausted all of my resources. I just can't figure out why the loop isn't getting to the other 2 ranges.

'Get current sheet name
Dim activeSheetName As String
activeSheetName = ActiveSheet.Name

'Create a new sheet to reformat existing data
Dim newSheetName As String
newSheetName = (activeSheetName + "_Data")

Dim filterRange As range
Dim areasCount As Integer
For Each a In filterRange.Areas
    Sheets(newSheetName).Select
    filterRange.Select
    range(Selection, Selection.End(xlToRight)).Select
    areasCount = Selection.Areas.Count
    With a
        For i = 2 To areasCount + 1
            Selection.Copy
            With Sheets.Add(After:=Sheets(Sheets.Count))
                .Name = a.Cells(1, 1).Value
                .range("A1").Value = a.Offset(, 1)
                range("A50").Select
                Selection.PasteSpecial paste:=xlPasteAll, Operation:=xlNone, _
                    SkipBlanks:= False, Transpose:=False
                Application.CutCopyMode = False
            End With
        Next i
    End With
Next a

I have tried to incorporate the following code I found in a book, but no such luck.

Dim SelAreas() As range
Dim pasteRange As range
Dim upperLeft As range
Dim numAreas As Long, i As Long
Dim topRow As Long, leftCol As Long
Dim rowOffset As Long, colOffset As Long

If TypeName(Selection) <> "Range" Then Exit Function

numAreas = Selection.Areas.Count
ReDim SelAreas(1 To numAreas)

For i = 1 To numAreas
    Set SelAreas(i) = Selection.Areas(i)
Next

topRow = ActiveSheet.Rows.Count
leftCol = ActiveSheet.Columns.Count

For i = 1 To numAreas
    If SelAreas(i).Row < topRow Then topRow = SelAreas(i).Row
    If SelAreas(i).Column < leftCol Then leftCol = SelAreas(i).Column
Next

Set upperLeft = Cells(topRow, leftCol)

On Error Resume Next
Set pasteRange = range("A50")
On Error GoTo 0

If TypeName(pasteRange) <> "Range" Then Exit Function

Set pasteRange = pasteRange.range("A1")

For i = 1 To numAreas
    rowOffset = SelAreas(i).Row - topRow
    colOffset = SelAreas(i).Column - leftCol
    SelAreas(i).Copy
    range("A1").Value = pasteRange.Offset(rowOffset, colOffset)
Next i

You aren't copying your `area` under variable `a` you are doing `Selection.Copy`. And `Selection` is basically `range(FilterRange, FilterRange.End(xlToRight))`. Why loop through `areas` of `FilterRange` and then copy a `Selection` made from `FilterRange`? — JNevill, Nov 19 '19 at 21:08
Might as will show sample data and result so we can see how your data is laid out? — L42, Nov 19 '19 at 21:08
You may find [this to be useful](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba) — cybernetic.nomad, Nov 19 '19 at 21:13
@JNevill I cannot thank you enough for asking me this question! I thought it out and tried some things, and ended up fixing the problem. I will post the answer below. — atschoe, Nov 19 '19 at 21:48
That's great news! I was going to take a shot at what I thought you might be going for, but I wasn't certain enough and thought I would just add to the confusion. — JNevill, Nov 19 '19 at 21:49
@JNevill Answer has been added to comments. Seriously, thank you so SO much. I'm new to VBA and have been working on this problem for a few days now, I really didn't think I'd ever find a solution. You've been a great help! — atschoe, Nov 19 '19 at 21:56

score 0 · Answer 1 · answered Nov 19 '19 at 21:53

For Each a In filterRange.Areas

    Sheets(newSheetName).Select
    range(a, a.End(xlToRight)).Copy

    With a
    If filterRange Is Nothing Then
       MsgBox ("Value not present in this workbook.")
    Else
        With Sheets.Add(After:=Sheets(Sheets.Count))
             .Name = a.Cells(1, 1).Value
             .range("A1").Value = a.Offset(, 1)
             range("A50").Select
             ActiveSheet.paste
        End With
             range("A10:A49").Select
             range(Selection, Selection.End(xlToRight)).Select
             Selection.Delete
             range("A1").Select
    End If
    End With
Next a

Properly looping through non-contiguous ranges?

1 Answers1