Excel Macro

[MyFlight]

Help I am trying to write a macro to Open Multiple (.txt) files located in the My Documents directory. After opening each file I want to CUT the contents and paste them into another spreadsheet (Master List.xls), then close the text file and move on to the next one. Since I have about 168 files I need to append it will take a long time manually.

I know how to open all of the files in the My Documents folder.

Sub Dpn_Formatting()
'
' Dpn_Formatting Macro
'
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ChDir "C:\Temp Data Files\Raw Data"
Workbooks.OpenText Filename:="*.DPN", _
Origin:=437, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array( _
Array(0, 2), Array(5, 2), Array(13, 2), Array(27, 2), Array(41, 2), Array(47, 2)), _
TrailingMinusNumbers:=True


However, I don't know how to cut and paste (append) the data to the Master List.xls file.

Any help would be appreicated.

 

[macropod]

Hi MyFlight,

You shouldn't need to use an intermediate file - the data can be written directly to your target file unless you have particular reasons for not doing so. The following code shows one way you might go about writing directly to your target file.

Cheers

Private Sub MacroEntry()
SBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.ScreenUpdating = False
Application.Calculation = xlManual
End Sub

Private Sub MacroExit()
Application.Calculation = xlAutomatic
Application.StatusBar = False
Application.DisplayStatusBar = SBar
Application.ScreenUpdating = True
End Sub

Sub ProcessFiles()
Dim fs
Dim FileDir
Dim FileList
Dim FileNum As Integer
Dim Counter As Long
Dim ResultStr As String
Dim i As Integer
Dim j As Integer
Call MacroEntry
'Use the fso to retrieve a list of files
Set fs = Application.FileSearch
'Folder to search
FileDir = "C:\Temp Data Files\Raw Data\"
With fs
    'File types to find
    .FileName = "*.DPN"
    If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then
        MsgBox "There were " & .FoundFiles.Count & " file(s) found."
        'Dimension the FileList array to hold the filenames
        ReDim FileList(.FoundFiles.Count)
        'Put each filename into the FileList array
        For i = 1 To .FoundFiles.Count
            FileList(i) = fs.FoundFiles(i)
        Next i
    Else
        MsgBox "There were no files found."
        Exit Sub
    End If
End With
'Process each file in the FileList array
For i = 1 To UBound(FileList)
    MsgBox FileList(i)
    'Get the next available file handle number
    FileNum = FreeFile()
    'Open text file for input
    Open FileList(i) For Input As #FileNum
    'Loop until the end of this file is reached
    Do While Not EOF(FileNum)
        'Store one line of text from file to 'ResultStr' variable
        Line Input #FileNum, ResultStr
        'Display Importing Row Number On Status Bar
        Application.StatusBar = "Importing Row " & Counter & " of text file " & FileName
        'Store One Line Of Text From File To Variable
        Line Input #FileNum, ResultStr
        'Store Variable Data Into Active Cell
        With ActiveCell
            .Value = ResultStr
            .TextToColumns DataType:=xlFixedWidth, FieldInfo:=Array( _
            Array(0, 2), Array(5, 2), Array(13, 2), Array(27, 2), Array(41, 2), Array(47, 2))
        End With
        'Swap trailing '-' signs to lead position
        For j = 0 To 5
            If Right(ActiveCell.Offset(0, j).Value, 1) = "-" Then _
            ActiveCell.Offset(0, j).Value = "-" & Left(ActiveCell.Offset(0, j).Value, 1)
        Next
        'For Excel versions before Excel 97, change 65536 to 16384
        If ActiveCell.Row = 65536 Then
            'If On The Last Row Then Add A New Sheet
            ActiveWorkbook.Sheets.Add
        Else
            'If Not The Last Row Then Go One Cell Down
            ActiveCell.Offset(1, 0).Select
        End If
        'Increment the Counter By 1
        Counter = Counter + 1
    'Start again at top of 'Do While' statement
    Loop
    'Close the open text file
    Close
'Open the next text file
Next
Call MacroExit
End Sub

 

[MyFlight]

MAcropad, The Macro comes back with No Files Found! I double chaecked and there are 10 Test (text) files in the directory.

Private Sub MacroEntry()
SBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.ScreenUpdating = False
Application.Calculation = xlManual
End Sub

Private Sub MacroExit()
Application.Calculation = xlAutomatic
Application.StatusBar = False
Application.DisplayStatusBar = SBar
Application.ScreenUpdating = True
End Sub

Sub ProcessFiles()
Dim fs
Dim FileDir
Dim FileList
Dim FileNum As Integer
Dim Counter As Long
Dim ResultStr As String
Dim i As Integer
Dim j As Integer
Call MacroEntry
'Use the fso to retrieve a list of files
Set fs = Application.FileSearch
'Folder to search
ChDir "C:\Hp8kData\"
FileDir = "C:\Hp8kData\"
With fs
'File types to find
MsgBox "The Data Directory " & FileDir & " ,is where the CDR Data file(s) are saved."
.Filename = "*.txt"
If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then
MsgBox "There were " & .FoundFiles.Count & " file(s) found."
'Dimension the FileList array to hold the filenames
ReDim FileList(.FoundFiles.Count)
'Put each filename into the FileList array
For i = 1 To .FoundFiles.Count
FileList(i) = fs.FoundFiles(i)
Next i
Else
MsgBox "There were no files found."
Exit Sub
End If
End With
'Process each file in the FileList array
For i = 1 To UBound(FileList)
MsgBox FileList(i)
'Get the next available file handle number
FileNum = FreeFile()
'Open text file for input
Open FileList(i) For Input As #FileNum
'Loop until the end of this file is reached
Do While Not EOF(FileNum)
'Store one line of text from file to 'ResultStr' variable
Line Input #FileNum, ResultStr
'Display Importing Row Number On Status Bar
Application.StatusBar = "Importing Row " & Counter & " of text file " & Filename
'Store One Line Of Text From File To Variable
Line Input #FileNum, ResultStr
'Store Variable Data Into Active Cell
With ActiveCell
.Value = ResultStr
.TextToColumns DataType:=xlFixedWidth, FieldInfo:=Array( _
Array(0, 2), Array(5, 2), Array(13, 2), Array(27, 2), Array(41, 2), Array(47, 2))
End With
'Swap trailing '-' signs to lead position
For j = 0 To 5
If Right(ActiveCell.Offset(0, j).Value, 1) = "-" Then _
ActiveCell.Offset(0, j).Value = "-" & Left(ActiveCell.Offset(0, j).Value, 1)
Next
'For Excel versions before Excel 97, change 65536 to 16384
If ActiveCell.Row = 65536 Then
'If On The Last Row Then Add A New Sheet
ActiveWorkbook.Sheets.Add
Else
'If Not The Last Row Then Go One Cell Down
ActiveCell.Offset(1, 0).Select
End If
'Increment the Counter By 1
Counter = Counter + 1
'Start again at top of 'Do While' statement
Loop
'Close the open text file
Close
'Open the next text file
Next
Call MacroExit
End Sub


Any Ideas what I may be doing wrong???

 

[macropod]

Hi MyFlight,

Sorry about that, in my code, the line:
.FileName = "*.DPN"
should have been:
.FileName = FileDir & "*.DPN"
So, in your's the equivalent line should be:
.Filename = FileDir & "*.txt"

Cheers
PS: you don't need to change folders (ie you can delete your ' ChDir "C:\Hp8kData\" ' statement)