Simplify macro

I need help simplifying this macro:

I run a report for every hour of the day.
A text file is saved into a directory as the following (0100 = 1:00 AM, 0200 = 2:00 AM, etc):

sv_toptrans 0100 FI.txt, sv_toptrans 0200 FI.txt, sv_toptrans 0300 FI.txt... sv_toptrans 2200 FI.txt, sv_toptrans 2300 FI.txt, sv_toptrans 2400 FI.txt (1 file for each hour - 24 files total)

I need the macro to look in the directory. Then copy the data to 'sheet1'. Then format the data. Finally move the data to to differernt worksheets.

This macro works as long as a have a text file for each hour.

If there is not a text file for a particular hour, I need the macro to skip it and move to the next hour. For example, if there is a sv_toptrans 0100 FI.txt file, it should copy the text file to the workbook, format it and then move the data to the different worksheets and then go to the sv_toptrans 0200 FI.txt file. If there is not a sv_toptrans 0200 FI.txt file, then it should move onto the sv_toptrans 0300 FI.txt file. If there is a sv_toptrans 0300 FI.txt file, it should format it and then move the data to the different worksheets and then go to the sv_toptrans 0400 FI.txt file.

================================================================

Sub toptrans()
'
' toptrans Macro
'
'
Dim CompanyArr
Dim DataSh As Worksheet
Dim LastRow As Long
Dim FilterRng As Range
Dim DataRng As Range
Dim DestSh As Worksheet
Dim f As Range
Dim StartVal As Long
Dim EndVal As Long

    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Documents and Settings\Desktop\New Folder\sv_toptrans 0100 FI.txt" _
        , Destination:=Range("$A$1"))
        .Name = "sv_toptrans 0100 FI"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(6, 6, 24, 13, 19, 3, 17, 12, 18)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Columns("A:B").Select
    Selection.Delete Shift:=xlToLeft
    Columns("D:D").Select
    Selection.Delete Shift:=xlToLeft
    Rows("1:12").Select
    Selection.Delete Shift:=xlUp
    Rows("10:15").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With
 
Set DataSh = Worksheets("Sheet1")
 
 
DataSh.Rows(1).Insert
DataSh.Range("A1") = "Company Name"
LastRow = DataSh.Range("A1").End(xlDown).Row
 
Set FilterRng = DataSh.Range("A1:A" & LastRow)
Set DataRng = DataSh.Range("A2:A" & LastRow)
       
FilterRng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=DataSh.Range("X1"), unique:=True
CompanyArr = DataSh.Range("X2", DataSh.Range("X" & Rows.Count).End(xlUp)).Value
DataSh.Columns("X").ClearContents
 
If Not IsArray(CompanyArr) Then
    Set DestSh = Worksheets(CompanyArr)
    FilterRng.AutoFilter field:=1, Criteria1:=CompanyArr
    For Each cell In DataRng.SpecialCells(xlCellTypeVisible)
        Set f = DestSh.Columns("D").Find(what:=cell.Offset(0, 2), after:=DestSh.Range("D1"), lookat:=xlWhole)
        If Not f Is Nothing Then
            cell.Resize(1, 7).Copy
            f.Offset(0, -2).PasteSpecial xlValues
        End If
    Next
Else
    For co = LBound(CompanyArr) To UBound(CompanyArr)
        Set DestSh = Worksheets(CompanyArr(co, 1))
        FilterRng.AutoFilter field:=1, Criteria1:=CompanyArr(co, 1)
        For Each cell In DataRng.SpecialCells(xlCellTypeVisible)
            Set f = DestSh.Columns("D").Find(what:=cell.Offset(0, 2), after:=DestSh.Range("D1"), lookat:=xlWhole)
            If Not f Is Nothing Then
                cell.Resize(1, 7).Copy
                f.EntireRow.Font.Color = vbBlack
                f.Offset(0, -2).PasteSpecial xlValues
            End If
        Next
    Next
End If
FilterRng.AutoFilter
FilterRng.EntireRow.ClearContents
 
With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Documents and Settings\Desktop\New Folder\sv_toptrans 0200 FI.txt" _
        , Destination:=Range("$A$1"))
        .Name = "sv_toptrans 0100 FI"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(6, 6, 24, 13, 19, 3, 17, 12, 18)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Columns("A:B").Select
    Selection.Delete Shift:=xlToLeft
    Columns("D:D").Select
    Selection.Delete Shift:=xlToLeft
    Rows("1:12").Select
    Selection.Delete Shift:=xlUp
    Rows("10:15").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With
 
Set DataSh = Worksheets("Sheet1")
 
 
DataSh.Rows(1).Insert
DataSh.Range("A1") = "Company Name"
LastRow = DataSh.Range("A1").End(xlDown).Row
 
Set FilterRng = DataSh.Range("A1:A" & LastRow)
Set DataRng = DataSh.Range("A2:A" & LastRow)
       
FilterRng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=DataSh.Range("X1"), unique:=True
CompanyArr = DataSh.Range("X2", DataSh.Range("X" & Rows.Count).End(xlUp)).Value
DataSh.Columns("X").ClearContents
 
If Not IsArray(CompanyArr) Then
    Set DestSh = Worksheets(CompanyArr)
    FilterRng.AutoFilter field:=1, Criteria1:=CompanyArr
    For Each cell In DataRng.SpecialCells(xlCellTypeVisible)
        Set f = DestSh.Columns("D").Find(what:=cell.Offset(0, 2), after:=DestSh.Range("D1"), lookat:=xlWhole)
        If Not f Is Nothing Then
            cell.Resize(1, 7).Copy
            f.Offset(0, -2).PasteSpecial xlValues
        End If
    Next
Else
    For co = LBound(CompanyArr) To UBound(CompanyArr)
        Set DestSh = Worksheets(CompanyArr(co, 1))
        FilterRng.AutoFilter field:=1, Criteria1:=CompanyArr(co, 1)
        For Each cell In DataRng.SpecialCells(xlCellTypeVisible)
            Set f = DestSh.Columns("D").Find(what:=cell.Offset(0, 2), after:=DestSh.Range("D1"), lookat:=xlWhole)
            If Not f Is Nothing Then
                cell.Resize(1, 7).Copy
                f.EntireRow.Font.Color = vbBlack
                f.Offset(0, -2).PasteSpecial xlValues
            End If
        Next
    Next
End If
FilterRng.AutoFilter
FilterRng.EntireRow.ClearContents
 
With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub

*** I repeat this for all 24 hours ***