Copy part of text file

[Steve]

Hello
I am trying to open a CSV file (File*.*) and copy a portion out of
that file into my work book. It runs up to the point of opening the
files. What is wrong with my code?

rnum = 1
Fnum = 1

MyPath = "C:\path\file"
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

FilesInPath = Dir(MyPath & "File*.*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
On Error GoTo CleanUp

Set basebook = ThisWorkbook

With Range("A3:AZ33")
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
.SpecialCells(xlCellTypeFormulas).ClearContents
On Error GoTo 0
End With

rnum = 0
Fnum = 0
Do While FilesInPath <> ""

If LCase(Right(FilesInPath, 10)) Like "File*.txt" Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
End If
FilesInPath = Dir()
Loop

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

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=""TEST""),(f
$2:f$500))"
Range("f1").AutoFill Range("F1:AE1")
Call SortArray(MyFiles)
SourceRcount = sourceRange.Rows.Count


With sourceRange
'this is the column
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

Thanks

 

[Rick Rothstein]

With Range("A3:AZ33")

On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
.SpecialCells(xlCellTypeFormulas).ClearContents
On Error GoTo 0
End With

Before I tell you where I think your problem is, let me address the above
from your code. If you are clearing all cells with either formulas or
constants in the range A3:AZ33, then why do them individually? I think this
single line replacement for the above would be simpler and quicker to
execute...

Range("A3:AZ33").ClearContents

If LCase(Right(FilesInPath, 10)) Like "File*.txt" Then

Now, as for your problem, I think it lies in the above line of code. You are
comparing all lower case text on the left with text that starts with an
upper case letter on the right... they will never match via the Like
operator... change the "F" on the right side to "f" and that will make that
portion of your code work. Just so you know, as you have this line of code
structured, the asterisk on the right side is a wildcard for only 0, 1 or 2
characters.. is that what you wanted? (Just checking to make sure you
realize that the ".txt" after the asterisk is counted as part of the 10
characters to the right of the contents of the FilesInPath variable.)

I looked, but wasn't completely sure what the rest of your code was doing;
however, I think it can be simplified. Can you explain in words exactly what
you are trying to have your code accomplish (don't tell us what your own
code is doing, rather, tell us what you have and what you want as a final
result afterwards).

 

[Steve]

Not sure why I did the separate clears (constand and then formulae).
This is a copy of old code. I dont have network access so I cant
test changes, but your comments on If LCase(Right(FilesInPath, 10))
Like "File*.txt" Then comments have me thinking and I believe I have
a fix, again a result of copying old code. I will test tomorrow and
post results.
Thanks for the response!

 

[Steve]

OK So I'm sure now that it is the If LCase(Right(FilesInPath, 10))
Like "File*.txt" Then bit that is getting me but Im not sure how to
fix it...

Here is the deal... I need to open a specific set of daily files in
the target folder. The file name is constructed as such,
abcYYYYMMDD.txt. The year and month are input earlier in the routine
and is working for that particular section of the routine. They are
both input as strings sYear and sMonth. I need to open each file for
the input year and month, insert a blank row at the top and insert the
formula =SUMPRODUCT(--($b$2:$b$500="TEST"),(f$2:f$500)) in F1:AE1.
Then copy F1:AE1 to my base book starting in AC3:AZ3, the next file
will paste into AC4:AZ4 and so on.

So how do I modify If LCase(Right(FilesInPath, 10)) Like "File*.txt"
I'm guessing that I should change it to Left and use abc and sYear and
sMonth some how but not sure exacly how.
Thanks!

 

[Steve]

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