Help with Vba, Data to table ready for access upload

Hi

I've and managed to bodge this together but there are a couple of thing im not happy with and i dont have a clue how to solve them

The Original data has the following headings in excel

EmployeeName|Skill|Team|1/1/15|2/1/15 (Etc x364)

the planners are using data validation lists with the activities and merfing the cells across the range required.

What i think this is now doing(What i would like it to do)
Its taking a schedule containing the merged cells, removing and replacing the data in the footprint of the merged cell,
finding all blank cells within the range and putting the formula in to show "Free" cells
pasting values in seperate workbook
taking the data and placing into list view with the following column headings

ID|EmployeeName|Skill|Team|Date|Data|ExportDate(now()

Sub mergeandfreeedited()
Range("D2:bc39").Select
Dim MergedCell As Range, FirstAddress As String, MergeAddress As String, MergeValue As Variant
  Application.FindFormat.MergeCells = True
  Do
    Set MergedCell = ActiveSheet.UsedRange.Find("", LookAt:=xlPart, SearchFormat:=True)
    If MergedCell Is Nothing Then Exit Do
    MergeValue = MergedCell.Value
    MergeAddress = MergedCell.MergeArea.Address
    MergedCell.MergeArea.UnMerge
    Range(MergeAddress).Value = MergeValue
  Loop
  Application.FindFormat.Clear
Range("Bg1").Select
     ActiveCell.FormulaR1C1 = "=IF(RC3="""","""",""Free"")"
    Range("Bg1").Select
    Selection.Copy
Range("D2:bc39").Select
    On Error Resume Next
   With Selection.SpecialCells(xlCellTypeBlanks).Select
   ActiveSheet.Paste
    End With
    
  
    Range("D2:bc39").Select
Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    If ActiveCell.CurrentRegion.Rows.Count < 2 Then
        Exit Sub
    End If
    If ActiveCell.CurrentRegion.Columns.Count < 4 Then
        Exit Sub
    End If
    
    Dim table As Range
    Dim rngColHead As Range
    Dim rngRowHead1 As Range
    Dim rngRowHead2 As Range
    Dim rngData As Range
    Dim cel As Range
    
    Dim rowVal1 As Variant
    Dim rowval2 As Varient
    Dim colVal As Variant
    Dim Val As Variant
    
    Set table = ActiveCell.CurrentRegion
    Set rngColHead = table.Rows(1)
    Set rngRowHead1 = table.Columns(1)
     Set rngRowHead2 = table.Columns(1)
    Set rngData = table.Offset(1, 0)
    '
    Set rngData = rngData.Resize(rngData.Rows.Count - 1, rngData.Columns.Count - 1)
    
    ActiveWorkbook.Worksheets.Add
    
    ActiveCell.Value = "Row#"
    ActiveCell.Offset(0, 1).Value = "EmployeeName"
    ActiveCell.Offset(0, 2).Value = "skill"
    ActiveCell.Offset(0, 3).Value = "team"
    ActiveCell.Offset(0, 4).Value = "Data"
    ActiveCell.Offset(1, 0).Select
    
    Dim n As Long
    For Each cel In rngData
        colVal = rngColHead.Cells(cel.Column - table.Column + 4)
        rowVal = rngRowHead.Cells(cel.Row - table.Row + 1)
        n = n + 1
        ActiveCell.Value = n
        ActiveCell.Offset(0, 1).Value = rowVal1
        ActiveCell.Offset(0, 2).Value = rowval2
        ActiveCell.Offset(0, 3).Value = colVal
        ActiveCell.Offset(0, 4).Value = cel.Value
        ActiveCell.Offset(1, 0).Select
Next
'_______________________________________________________________________-
End Sub

I have a macro recorded to fire it into an access database but this also has an error?

I need the code in told to be instead of selecting the range "[Sheet1$A1:c50]" it selects the active sheet and the finished range from above (note when converting to the table vew above it extends past 1000 rows

Sub AddDataFromWorkbookToAccess()

Dim cn As Object
Dim strWorkbook As String
Dim strDatabase As String
strDatabase = "C:\Users\robert.tuby\Documents\Scheduling Database.accdb"
strWorkbook = ThisWorkbook.FullName

Set cn = CreateObject("ADODB.Connection")

With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & strDatabase
.Open
' change table and field names here (Issue with below line.)'need to find way of selecting the range for SQL
.Execute "INSERT INTO table1 (C1,C2,C3,c4,c5,c6) SELECT * FROM [Excel 12.0;HDR=YES;Database=" & strWorkbook & "].[Sheet1$A1:c50]".Close
End With
MsgBox ("Done")
End Sub

any help would be appreciated

Thanks

Rob