Have information need to speed process

Sub MultipleDayInfo()

   Dim FromSheet  As Worksheet
   Dim ToSheet    As Worksheet
   Dim iRow       As Long     'Row number on FromSheet
   Dim nRows      As Long
   Dim nDates     As Integer  'Number of date column pairs in FromSheet
   Dim iDate      As Integer  'Date column pair index
   
   Set FromSheet = ActiveSheet
   Set ToSheet = Worksheets.Add(after:=FromSheet)
   
   nDates = FromSheet.Cells(1, 256).End(xlToLeft).Column / 2
   nRows = FromSheet.[A65536].End(xlUp).Row
   
   With FromSheet
      For iDate = 1 To nDates
         .Range(.Cells(3, iDate * 2 - 1), .Cells(nRows, iDate * 2)).Copy ToSheet.Cells(3 + (iDate - 1) * (nRows - 2), "A")
         ToSheet.Range(ToSheet.Cells(3 + (iDate - 1) * (nRows - 2), "C"), ToSheet.Cells(2 + iDate * (nRows - 2), "C")) = Day(FromSheet.Cells(1, iDate * 2))
      Next iDate
   End With
   
   'Sort by part
   With ToSheet
      .Range("A3", .Range("C65536").End(xlUp)).Sort Key1:=.Range("A3"), Header:=xlNo

   'Now combine multiple dates
   
      iRow = 3
      
      Do Until IsEmpty(.Cells(iRow, "A"))
         If .Cells(iRow + 1, "A") = .Cells(iRow, "A") Then
            If .Cells(iRow + 1, "B") = .Cells(iRow, "B") Then
               'eliminate row
               .Cells(iRow, "C") = .Cells(iRow, "C") & "," & .Cells(iRow + 1, "C")
               .Rows(iRow + 1).Delete
               GoTo DoAgain
            End If
         End If
         iRow = iRow + 1
DoAgain:
      Loop
   
      .Rows(1).ClearContents
      .Rows(1).Font.Bold = True
      .[A1] = "Location"
      .[B1] = "Code"
      .[C1] = "Dates"
      .Columns("A:C").HorizontalAlignment = xlCenter
   End With
   
End Sub