View Single Post
  #5   Report Post  
Posted to microsoft.public.excel.programming
Steve[_116_] Steve[_116_] is offline
external usenet poster
 
Posts: 3
Default 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