Copy part of text file
OK been tweaking and this is what I have so far...
rnum = 1
Fnum = 1
MyPath = "\\server\shares\groupdirs\923\hourlydata"
If Right(MyPath, 1) < "\" Then
MyPath = MyPath & "\"
End If
FilesInPath = Dir(MyPath & "abc*.*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
On Error GoTo CleanUp
rnum = 0
Fnum = 0
Do While FilesInPath < ""
sFileName = "abc_" & sYear & sMonth
If LCase(Left(FilesInPath, 10)) Like sFileName Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
End If
FilesInPath = Dir()
Loop
'Loop through all files in the array(myFiles)
If Fnum 0 Then
Call SortArray(MyFiles)
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Workbooks.OpenText Filename:=MyPath & MyFiles(Fnum),
Origin:=437 _
, StartRow:=1, DataType:=xlDelimited,
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False,
Comma:=False _
, Space:=False, Other:=False, FieldInfo:=Array(Array(1,
1), Array(2, 1), _
Array(3, 1), Array(4, 1), Array(5, 1)),
TrailingMinusNumbers:=True
Set mybook = ThisWorkbook
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"),
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False,
Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True,
OtherChar _
:=":", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1),
Array(4, 1), Array(5, _
1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1),
Array(10, 1), Array(11, 1), Array(12 _
, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1),
Array(17, 1), Array(18, 1), _
Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1),
Array(23, 1), Array(24, 1), Array( _
25, 1), Array(26, 1), Array(27, 1), Array(28, 1), Array(29, 1),
Array(30, 1), Array(31, 1)) _
, TrailingMinusNumbers:=True
Rows("1:1").Select
Selection.Insert Shift:=xlDown,
CopyOrigin:=xlFormatFromLeftOrAbove
Range("F1").Select
Range("F1").Formula = "=SUMPRODUCT(--($b$2:$b
$500=""Criteria""),(f$2:f$500))"
Range("f1").AutoFill Range("F1:AE1")
Set sourceRange = mybook.Worksheets(1).Range("F1:AE1")
Call SortArray(MyFiles)
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Range("AC" & rnum)
basebook.Worksheets(1).Cells(rnum + 2, "A").Value =
mybook.Name
With sourceRange
Set destrange =
basebook.Worksheets(1).Cells(rnum + 2, "AC"). _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
mybook.Close savechanges:=False
Next Fnum
End If
CleanUp:
Application.ScreenUpdating = True
End Sub
Sub SortArray(myArr As Variant)
Dim iCtr As Long
Dim jCtr As Long
Dim Temp As Variant
For iCtr = LBound(myArr) To UBound(myArr) - 1
For jCtr = iCtr + 1 To UBound(myArr)
If LCase(Right(myArr(iCtr), 10)) _
LCase(Right(myArr(jCtr), 10)) Then
Temp = myArr(iCtr)
myArr(iCtr) = myArr(jCtr)
myArr(jCtr) = Temp
End If
Next jCtr
Next iCtr
End Sub
It runs up to the point of Set destrange =
basebook.Worksheets(1).Range("AC" & rnum)
and then exits. Any ideas?
Thanks
|