Ways to parse cells in mulitple selected locations

[Nature]

I'm trying to write a macro to parse multiple selected cells and copy records
to another sheet. However, I can only make it work if these cells are in the
same region. I would like to make it workable even if they are sperated by
each others.
I have attached my code here. I would like to attach the excel file here too
but I can't find a way to do so..
Thank you for your help!

------------------------------------------------------------------------------------
Type Recordtype
CN As String
BU As String
DT As Date
ID As String
SN As String
End Type

Public record() As Recordtype

Sub gen()

Dim CN_cell As Range
Dim BU_cell As Range
Dim DT_cell As Range
Dim ID_cell As Range
Dim SN_cell As Range
Dim PreviousCell As Range
Dim today As String
Dim num As Integer

'parse column header

For Each Cell In Range("1:1")

Select Case Cell.Value

Case "Case#"
Set CN_cell = Cell
Case "BU"
Set BU_cell = Cell
Case "Date"
Set DT_cell = Cell
Case "ID"
Set ID_cell = Cell
Case "SN"
Set SN_cell = Cell

End Select

Next Cell

'determine number of record(s) selected

recordnum = Selection.Rows.Count
ReDim record(1 To recordnum) As Recordtype

'grab record(s) data

Set PreviousCell = Cells(1, 1)
i = 1

For Each Cell In Selection

If Not Cell.Row = PreviousCell.Row Then

record(i).CN = Cells(Cell.Row, CN_cell.Column).Value
record(i).BU = Cells(Cell.Row, BU_cell.Column).Value
record(i).DT = Cells(Cell.Row, DT_cell.Column).Value
record(i).ID = Cells(Cell.Row, ID_cell.Column).Value
record(i).SN = Cells(Cell.Row, SN_cell.Column).Value

i = i + 1

End If

Set PreviousCell = Cell

Next Cell

'add new sheet by today's date

today = Format(Date, "dd-mmm-yy")
num = 1

Do Until SheetExist(today) = False

today = Format(Date, "dd-mmm-yy") & "(" & num & ")"
num = num + 1

Loop

Sheets.Add.Name = today

'write selected record(s) to the new sheet

For i = 1 To recordnum
Cells(i, 1) = record(i).CN
Cells(i, 2) = record(i).ID
Cells(i, 3) = record(i).SN
Cells(i, 4) = record(i).BU
Next i

'insert column header
Range("1:1").Rows.Insert
Cells(1, 1) = CN_cell
Cells(1, 2) = ID_cell
Cells(1, 3) = SN_cell
Cells(1, 4) = BU_cell

End Sub

Function SheetExist(SheetName As String) As Boolean

Dim i As Integer

For i = 1 To Sheets.Count
If (Worksheets(i).Name = SheetName) Then
SheetExist = True
Exit Function
Else
SheetExist = False
End If
Next

End Function