Properly looping through non-contiguous ranges? - excel

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

Answer 1

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