1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
|
Option Explicit
Public sFolder As String
Public sFilename() As String
Public NFiles As Integer
Sub GetFileList()
Dim varFileList As Variant
Dim i As Integer
' Get the directory from the user'
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then Exit Sub 'user cancelled'
sFolder = .SelectedItems(1)
End With
' Get a list of all the files in this directory.'
' Note that this isn't recursive... although it could be...'
varFileList = GetFileNames(sFolder, "*.txt")
If Not IsArray(varFileList) Then
MsgBox "No files found.", vbInformation
Exit Sub
End If
' Setup the filename array based on the selected directory'
NFiles = UBound(varFileList) + 1
ReDim sFilename(1 To NFiles)
' Copy the filenames into a string array for use elsewhere'
For i = 0 To UBound(varFileList)
sFilename(i + 1) = CStr(varFileList(i))
Next i
OutputFilenames2XL
ImportFileContent
End Sub
Private Function GetFileNames(ByVal sPath As String, Optional sFilter As String) As Variant
' Returns a one dimensional array with filenames'
' Otherwise returns False'
Dim f As String
Dim i As Integer
Dim FileList() As String
If sFilter = "" Then sFilter = "*.*"
Select Case Right$(sPath, 1)
Case "\", "/"
sPath = Left$(sPath, Len(sPath) - 1)
End Select
ReDim Preserve FileList(0)
f = Dir$(sPath & "\" & sFilter)
Do While Len(f) > 0
ReDim Preserve FileList(i) As String
FileList(i) = f
i = i + 1
f = Dir$()
Loop
If FileList(0) <> Empty Then
GetFileNames = FileList
Else
GetFileNames = False
End If
End Function
Private Sub OutputFilenames2XL()
Dim iBaseRow As Integer, iBaseCol As Integer
Dim shTarget As Worksheet
Dim i As Integer
Set shTarget = Application.ActiveSheet
iBaseRow = Range("BaseCell").Row
iBaseCol = Range("BaseCell").Column
'Populate the header fields'
shTarget.Range("ImportDate").Value = Now
shTarget.Range("FolderPath").Value = sFolder
shTarget.Range("NFiles") = NFiles
'Populate filename column of the table'
For i = 1 To NFiles
shTarget.Cells(iBaseRow + i - 1, iBaseCol).Value = sFilename(i)
Next i
'Put formula to parse transaction id into first column'
shTarget.Range(Cells(iBaseRow, iBaseCol - 1), Cells(iBaseRow + NFiles - 1, iBaseCol - 1)).FormulaR1C1 = "=MID(R[0]C[1],LEN(R[0]C[1])-14,8)"
End Sub
Private Sub ImportFileContent()
Dim i As Integer, j As Integer
Dim shTarget As Worksheet
Dim iBaseRow As Integer, iBaseCol As Integer
Dim shSource As Worksheet
Dim sActiveFilename As String
Dim sFullPath As String
Dim iRowCount As Integer
Dim iTargetColumn As Integer
Dim rSourceRange As Range
'Store base data for the target worksheet we are building'
Set shTarget = Application.ActiveSheet
iBaseRow = Range("BaseCell").Row
iBaseCol = Range("BaseCell").Column
'Now process each filename just imported to the worksheet'
Application.ScreenUpdating = False
Application.WindowState = xlMinimized
Application.Calculation = xlCalculationManual
Application.Visible = False
'Setup progress bar'
Load frmProgress
frmProgress.ProgressBar.Max = NFiles
frmProgress.ProgressBar.Value = 0
frmProgress.Show
For i = 1 To NFiles
sActiveFilename = sFilename(i)
sFullPath = sFolder & "\" & sActiveFilename
'Import delimited text file'
Workbooks.OpenText Filename:=sFullPath, _
Origin:=437, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=True
'Store the sheet name and format / add formulas required'
Set shSource = Application.ActiveSheet
iRowCount = Application.WorksheetFunction.CountA(Columns("A:A"))
shSource.Range(Cells(1, 2), Cells(iRowCount, 2)).FormulaR1C1 = "=FIND("":"",R[0]C[-1])"
shSource.Range(Cells(1, 3), Cells(iRowCount, 3)).FormulaR1C1 = "=IF(LEFT(R[0]C[-2],7)=""Comment"",61,VALUE(MID(R[0]C[-2],2,R[0]C[-1]-2)))"
shSource.Range(Cells(1, 4), Cells(iRowCount, 4)).FormulaR1C1 = "=RIGHT(R[0]C[-3],LEN(R[0]C[-3])-R[0]C[-2]-1)"
'Make sure the cells are updated with the current data (only needed if calculation is set to manual)'
shSource.Calculate
'Now copy the resulting parsed data into the correct cells on the target worksheet'
For j = 1 To iRowCount
iTargetColumn = CInt(shSource.Cells(j, 3).Value)
Set rSourceRange = shSource.Cells(j, 4)
shTarget.Cells(iBaseRow + i - 1, iBaseCol + iTargetColumn).Value = rSourceRange.Value
Next j
'Finally close the source workbook file since we are finished with it'
Workbooks(sActiveFilename).Close SaveChanges:=False
frmProgress.ProgressBar.Value = i
frmProgress.Repaint
Next i
shTarget.Columns("C:BK").EntireColumn.AutoFit
frmProgress.Hide
Application.Calculation = xlCalculationAutomatic
Application.Calculate
Application.ScreenUpdating = True
Application.WindowState = xlMaximized
Application.Visible = True
End Sub
|
