Simplify macro

**iamasimpleman** · 01-28-2011, 09:35 PM

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 ***

**Marcol** · 01-28-2011, 09:47 PM

Hi iamasimpleman

Welcome to the Forum

Please wrap your code in code tags, before the moderators get you...

Forum rules

3. Use code tags around code. Posting code without them makes your code hard to read and difficult to be copied for testing. Highlight your code and click the # button at the top of the post window. If you are editing an existing post, press Go Advanced to see the # button.

Cheers

**JBeaucaire** · 01-29-2011, 04:33 AM

Try this:

Option Explicit

Sub toptrans()
Dim CompanyArr  As Variant
Dim TimesArr    As Variant
Dim DataSh      As Worksheet
Dim DestSh      As Worksheet
Dim FilterRng   As Range
Dim DataRng     As Range
Dim cell        As Range
Dim f           As Range
Dim LastRow     As Long
Dim StartVal    As Long
Dim EndVal      As Long
Dim TimeVal     As Long
Dim co          As Long
Dim fileStr     As String

Set DataSh = Sheets("Sheet1")
TimesArr = Array("0100", "0200", "0300", "0400", "0500", "0600", _
                 "0700", "0800", "0900", "1000", "1100", "1200", _
                 "1300", "1400", "1500", "1600", "1700", "1800", _
                 "1900", "2000", "2100", "2200", "2300", "2400")
Application.ScreenUpdating = False
Application.DisplayAlerts = False


For TimeVal = LBound(TimesArr) To UBound(TimesArr)
    fileStr = "C:\Documents and Settings\Desktop\New Folder\sv_toptrans " _
                        & TimesArr(TimeVal) & " FI.txt"

    If Not (Dir(fileStr, vbDirectory)) = vbNullString Then
        With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fileStr, Destination:=Range("$A$1"))
            .Name = "sv_toptrans " & TimesArr(TimeVal) & " 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").Delete Shift:=xlToLeft
        Columns("D:D").Delete Shift:=xlToLeft
        Rows("1:12").Delete Shift:=xlUp
        Rows("10:15").Delete Shift:=xlUp
        
        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 cell
        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 cell
            Next co
        End If
        FilterRng.AutoFilter
        FilterRng.EntireRow.ClearContents
    End If
Next TimeVal

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

**iamasimpleman** · 01-29-2011, 05:55 AM

Thank you JBeaucaire. This is exactly what I was looking for. Thanks for all the help.

**broro183** · 01-29-2011, 07:01 AM

hi everyone,

I haven't tried JB's code but I suggest one small change to it, because I think you may end up with a lot of redundant ("duplicate") connections in your workbook if the code is repeatedly run. Of course, I could be wrong...

'try replacing the below...
                    .Refresh BackgroundQuery:=False
                End With

'with these three lines...
                    .Refresh BackgroundQuery:=False
                    .Delete
                End With

iamasimpleman,
If you're happy with JB's solution, can you please mark the thread as Solved?
(see Rules for details)

Rob