Data search and extraction from multiple text files query

[joecrabtree]

To all,


I have a series of comma seperated text files. One for each day of the
year. They are identified by the title RD071107, RD071108 etc. - This
denotes the date that the data was collected (yy/mm/dd). In each text
file there is comma serpated data in the format shown below:

Date,Time,Pierce_Position,Pierce_Pressure,Clamp_Position,Clamp_Pressure,Current_Job,Toolslide_Position,Press
Mode,Rotary 1 Furnace Temperature,Rotary 2 Furnace Temperature
2007/13/11,01:02:41,1506.,32.,-2,4102.,35900,2,Manual,0,0
2007/13/11,01:02:41,1506.,31.,-2,4379.,35900,2,Manual,0,0
2007/13/11,01:02:42,1506.,32.,-2,4378.,35900,2,Manual,0,0
2007/13/11,01:02:42,1506.,31.,-2,4363.,35900,2,Manual,0,0
2007/13/11,01:02:43,1506.,31.,-2,4345.,35900,2,Manual,0,0
2007/13/11,01:02:43,1506.,31.,-2,4328.,35900,2,Manual,0,0
2007/13/11,08:44:12,541.,92.,2,472.,35602,4,Auto,0,0
2007/13/11,08:44:13,697.,93.,2,468.,35602,4,Auto,0,0
2007/13/11,08:44:13,877.,94.,1,465.,35602,4,Auto,0,0
2007/13/11,08:44:14,1012.,94.,1,462.,35602,4,Auto,0,0
2007/13/11,08:44:14,1012.,84.,1,459.,35602,4,Auto,0,0
2007/13/11,08:44:15,1206.,74.,1,456.,35602,4,Auto,0,0
2007/13/11,08:44:15,1259.,69.,1,454.,35602,4,Auto,0,0
2007/13/11,08:44:16,1290.,72.,1,452.,35602,4,Manual,0,0


The important data for me is the current_job number which is a 5 digit
numeric number - in the example above it is 35900. Each text file
contains multiple job numbers.

What I want to be able to do is search through each text file (one per
day in a master folder) and extract all the data for a particular job.
So for the job number 35900 it would extract the following from the
text file. It would repeat this for each day.

2007/13/11,01:02:41,1506.,32.,-2,4102.,35900,2,Manual,0,0
2007/13/11,01:02:41,1506.,31.,-2,4379.,35900,2,Manual,0,0
2007/13/11,01:02:42,1506.,32.,-2,4378.,35900,2,Manual,0,0
2007/13/11,01:02:42,1506.,31.,-2,4363.,35900,2,Manual,0,0
2007/13/11,01:02:43,1506.,31.,-2,4345.,35900,2,Manual,0,0
2007/13/11,01:02:43,1506.,31.,-2,4328.,35900,2,Manual,0,0

I then want to be able to import the data found into an excel workbook
titled with the job number 35900, with a seperate worksheet for each
day of data extracted.

Is there a quick way to do this, if so any help would be appreciated.

Thanks in advance for your help,

Regard

Joseph Crabtree

 

[Joel]

This is a little complicated but it works well good.

You need to modify this line to point to the directory where the data is
located
Const Folder = "C:\temp\test"

Change this line for different Job Numbers

Const JobNumber = 35900




Sub GetFurnaceData()

Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const Folder = "C:\temp\test"
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Const JobNumber = 35900
Dim field(11)

'check if temporary worksheet exists
Found = False
For Each sht In ThisWorkbook.Sheets
If sht.Name = "Temporary" Then
Found = True
Exit For
End If
Next sht

If Found = False Then
With ThisWorkbook.Sheets
.Add after:=ThisWorkbook.Sheets(.Count)
ActiveSheet.Name = "Temporary"
End With
Else
ThisWorkbook.Worksheets("Temporary").Cells.ClearContents
End If


Set fsread = CreateObject("Scripting.FileSystemObject")
TempRowCount = 1
First = True
Do
If First = True Then
Filename = Dir(Folder & "\*.csv")
First = False
Else
Filename = Dir()
End If
If Filename <> "" Then
'open files
Set fread = fsread.GetFile(Folder & "\" & Filename)
Set tsread = fread.OpenAsTextStream(ForReading, TristateUseDefault)

Do While tsread.atendofstream = False

Inputline = tsread.Readline

'extract comma seperated data
For i = 1 To 11
If i < 11 Then
CommaPosition = InStr(Inputline, ",")
If CommaPosition > 0 Then
data = Trim(Left(Inputline, CommaPosition - 1))
Inputline = Mid(Inputline, CommaPosition + 1)
field(i) = data
Else
field(i) = ""
End If
Else
field(i) = Trim(Inputline)
End If
Next i
If JobNumber = Val(field(7)) Then
For i = 1 To 11
With ThisWorkbook.Sheets("Temporary")
.Cells(TempRowCount, i) = field(i)
End With
Next i
TempRowCount = TempRowCount + 1
End If
Loop

tsread.Close
End If
Loop While Filename <> ""

With ThisWorkbook.Sheets("Temporary")

Lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
'Sort by date
.Range("A1:K" & Lastrow).Sort _
Key1:=.Range("A1"), _
Order1:=xlAscending, _
Header:=xlGuess, _
DataOption1:=xlSortNormal

'move data to sheets by date
NewDate = .Range("A1")
NewYear = Val(Left(NewDate, 4))
NewDate = Mid(NewDate, 6)
NewMonth = Left(NewDate, InStr(NewDate, "/") - 1)
NewDay = Mid(NewDate, InStr(NewDate, "/") + 1)

StrDate = NewYear & "_" & NewMonth & "_" & NewDay
NewRowCount = 1
ThisWorkbook.Sheets.Add _
after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = StrDate
RowCount = 1
Do While .Range("A" & RowCount) <> ""
.Rows(RowCount).Copy Destination:= _
ThisWorkbook.Sheets(StrDate).Rows(NewRowCount)
NewRowCount = NewRowCount + 1
If .Range("A" & RowCount) <> .Range("A" & RowCount + 1) Then
If .Range("A" & RowCount + 1) <> "" Then
NewRowCount = 1
ThisWorkbook.Sheets.Add _
after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
NewDate = .Range("A" & RowCount + 1)
NewYear = Val(Left(NewDate, 4))
NewDate = Mid(NewDate, 6)
NewMonth = Left(NewDate, InStr(NewDate, "/") - 1)
NewDay = Mid(NewDate, InStr(NewDate, "/") + 1)
StrDate = NewYear & "_" & NewMonth & "_" & NewDay
ActiveSheet.Name = StrDate
End If
End If
RowCount = RowCount + 1
Loop
End With
End Sub

 

[joecrabtree]

This is a little complicated but it works well good.

You need to modify this line to point to the directory where the data is
located
Const Folder = "C:\temp\test"

Change this line for different Job Numbers

Const JobNumber = 35900

Sub GetFurnaceData()

Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const Folder = "C:\temp\test"
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Const JobNumber = 35900
Dim field(11)

'check if temporary worksheet exists
Found = False
For Each sht In ThisWorkbook.Sheets
If sht.Name = "Temporary" Then
Found = True
Exit For
End If
Next sht

If Found = False Then
With ThisWorkbook.Sheets
.Add after:=ThisWorkbook.Sheets(.Count)
ActiveSheet.Name = "Temporary"
End With
Else
ThisWorkbook.Worksheets("Temporary").Cells.ClearContents
End If

Set fsread = CreateObject("Scripting.FileSystemObject")
TempRowCount = 1
First = True
Do
If First = True Then
Filename = Dir(Folder & "\*.csv")
First = False
Else
Filename = Dir()
End If
If Filename <> "" Then
'open files
Set fread = fsread.GetFile(Folder & "\" & Filename)
Set tsread = fread.OpenAsTextStream(ForReading, TristateUseDefault)

Do While tsread.atendofstream = False

Inputline = tsread.Readline

'extract comma seperated data
For i = 1 To 11
If i < 11 Then
CommaPosition = InStr(Inputline, ",")
If CommaPosition > 0 Then
data = Trim(Left(Inputline, CommaPosition - 1))
Inputline = Mid(Inputline, CommaPosition + 1)
field(i) = data
Else
field(i) = ""
End If
Else
field(i) = Trim(Inputline)
End If
Next i
If JobNumber = Val(field(7)) Then
For i = 1 To 11
With ThisWorkbook.Sheets("Temporary")
.Cells(TempRowCount, i) = field(i)
End With
Next i
TempRowCount = TempRowCount + 1
End If
Loop

tsread.Close
End If
Loop While Filename <> ""

With ThisWorkbook.Sheets("Temporary")

Lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
'Sort by date
.Range("A1:K" & Lastrow).Sort _
Key1:=.Range("A1"), _
Order1:=xlAscending, _
Header:=xlGuess, _
DataOption1:=xlSortNormal

'move data to sheets by date
NewDate = .Range("A1")
NewYear = Val(Left(NewDate, 4))
NewDate = Mid(NewDate, 6)
NewMonth = Left(NewDate, InStr(NewDate, "/") - 1)
NewDay = Mid(NewDate, InStr(NewDate, "/") + 1)

StrDate = NewYear & "_" & NewMonth & "_" & NewDay
NewRowCount = 1
ThisWorkbook.Sheets.Add _
after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = StrDate
RowCount = 1
Do While .Range("A" & RowCount) <> ""
.Rows(RowCount).Copy Destination:= _
ThisWorkbook.Sheets(StrDate).Rows(NewRowCount)
NewRowCount = NewRowCount + 1
If .Range("A" & RowCount) <> .Range("A" & RowCount + 1) Then
If .Range("A" & RowCount + 1) <> "" Then
NewRowCount = 1
ThisWorkbook.Sheets.Add _
after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
NewDate = .Range("A" & RowCount + 1)
NewYear = Val(Left(NewDate, 4))
NewDate = Mid(NewDate, 6)
NewMonth = Left(NewDate, InStr(NewDate, "/") - 1)
NewDay = Mid(NewDate, InStr(NewDate, "/") + 1)
StrDate = NewYear & "_" & NewMonth & "_" & NewDay
ActiveSheet.Name = StrDate
End If
End If
RowCount = RowCount + 1
Loop
End With
End Sub











- Show quoted text -

Thanks for that. I however have one problem. When I run it it comes
back with the following error message:

'Run time error '1004' Application defined object or object define
error

This occurs at .Cells(TempRowCount, i) = field(i)

I am assuming this is because I have used over 65000 rows of data in
excel. Is there any way that after it has imported say 60000 lines of
data, it puts the next set on a second sheet i.e. temporary 2 etc?
Also will the data split by date function have to be modified
accordingly?

Thanks

Joseph Crabtree

 

[Joel]

I don't like making assumptions. Not sure if we got to 65,536 lines or if
Temprowcount just have to be defined as a long. Can you check how many rows
are filled onthe temporary worksheet. If 65,536 rows are filled then we need
to modify the code. If there are less than 65,536 then try adding a statement

Dim TempRowCount as long

 

[joecrabtree]

Joel,

65536 rows are filled.

Thanks

Joe

I don't like making assumptions. Not sure if we got to 65,536 lines or if
Temprowcount just have to be defined as a long. Can you check how many rows
are filled onthe temporary worksheet. If 65,536 rows are filled then we need
to modify the code. If there are less than 65,536 then try adding a statement

Dim TempRowCount as long

 

[Joel]

Try this code. I made the code modula adding a function and a subroutine to
perform functions required in multiple places in the code. When 65,536 lines
are reached I move the data to individual sheets and then clear the temporary
page.

I modified the date so a serial date is inserted in the worksheet instead of
the string date that existed in the previous code.

Remember to chage the path name
Const Folder = "C:\temp\test"

Also I'm searching for files *.csv (I assume the this is the name of the
files).


Sub GetFurnaceData()

Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const Folder = "C:\temp\test"
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Const JobNumber = 35900
Dim field(11)

'check if temporary worksheet exists
Found = False
For Each sht In ThisWorkbook.Sheets
If sht.Name = "Temporary" Then
Found = True
Exit For
End If
Next sht

If Found = False Then
With ThisWorkbook.Sheets
.Add after:=ThisWorkbook.Sheets(.Count)
ActiveSheet.Name = "Temporary"
End With
Else
ThisWorkbook.Worksheets("Temporary").Cells.ClearContents
End If


Set fsread = CreateObject("Scripting.FileSystemObject")
TempRowCount = 1
First = True
Do
If First = True Then
Filename = Dir(Folder & "\*.csv")
First = False
Else
Filename = Dir()
End If
If Filename <> "" Then
'open files
Set fread = fsread.GetFile(Folder & "\" & Filename)
Set tsread = fread.OpenAsTextStream(ForReading, TristateUseDefault)

Do While tsread.atendofstream = False

Inputline = tsread.Readline

'extract comma seperated data
For i = 1 To 11
If i < 11 Then
CommaPosition = InStr(Inputline, ",")
If CommaPosition > 0 Then
data = Trim(Left(Inputline, CommaPosition - 1))
Inputline = Mid(Inputline, CommaPosition + 1)
field(i) = data
Else
field(i) = ""
End If
Else
field(i) = Trim(Inputline)
End If
Next i
If JobNumber = Val(field(7)) Then

'convert data to a serial format
NewDate = field(1)
NewYear = Val(Left(NewDate, 4))
NewDate = Mid(NewDate, 6)
NewMonth = Val(Left(NewDate, InStr(NewDate, "/") - 1))
NewDay = Val(Mid(NewDate, InStr(NewDate, "/") + 1))
field(1) = DateSerial(NewYear, NewMonth, NewDay)
For i = 1 To 11
With ThisWorkbook.Sheets("Temporary")
.Cells(TempRowCount, i) = field(i)
End With
Next i
If TempRowCount = Rows.Count Then
Call movedata
ThisWorkbook.Worksheets("Temporary").Cells.ClearContents
TempRowCount = 1
Else
TempRowCount = TempRowCount + 1
End If
End If
Loop

tsread.Close
End If
Loop While Filename <> ""
If Not IsEmpty(ThisWorkbook.Worksheets("Temporary").Range("A1")) Then
Call movedata
End If
End Sub
Sub movedata()
With ThisWorkbook.Sheets("Temporary")

LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
'Sort by date
.Range("A1:K" & LastRow).Sort _
Key1:=.Range("A1"), _
Order1:=xlAscending, _
Header:=xlGuess, _
DataOption1:=xlSortNormal

'move data to sheets by date
NewDate = .Range("A1")
StrDate = Year(NewDate) & "_" & Month(NewDate) & "_" & Day(NewDate)
NewRowCount = Findsheet(StrDate)

RowCount = 1
Do While .Range("A" & RowCount) <> ""
.Rows(RowCount).Copy Destination:= _
ThisWorkbook.Sheets(StrDate).Rows(NewRowCount)
NewRowCount = NewRowCount + 1
If .Range("A" & RowCount) <> .Range("A" & RowCount + 1) Then
If .Range("A" & RowCount + 1) <> "" Then
NewDate = .Range("A" & RowCount + 1)
StrDate = Year(NewDate) & "_" & Month(NewDate) & "_" &
Day(NewDate)
NewRowCount = Findsheet(StrDate)

End If
End If
RowCount = RowCount + 1
Loop
End With
End Sub

Function Findsheet(StrDate) As Integer

'check if worksheet exists
Found = False
For Each wbk In ThisWorkbook.Sheets
If wbk.Name = StrDate Then
Found = True
Exit For
End If
Next wbk

If Found = True Then
LastRow = wbk.Cells(Rows.Count, "A").End(xlUp).Row
Findsheet = LastRow + 1
Else
Findsheet = 1
ThisWorkbook.Sheets.Add _
after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = StrDate
End If

End Function

 

[joecrabtree]

Try this code. I made the code modula adding a function and a subroutine to
perform functions required in multiple places in the code. When 65,536 lines
are reached I move the data to individual sheets and then clear the temporary
page.

I modified the date so a serial date is inserted in the worksheet instead of
the string date that existed in the previous code.

Remember to chage the path name
Const Folder = "C:\temp\test"

Also I'm searching for files *.csv (I assume the this is the name of the
files).

Sub GetFurnaceData()

Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const Folder = "C:\temp\test"
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Const JobNumber = 35900
Dim field(11)

'check if temporary worksheet exists
Found = False
For Each sht In ThisWorkbook.Sheets
If sht.Name = "Temporary" Then
Found = True
Exit For
End If
Next sht

If Found = False Then
With ThisWorkbook.Sheets
.Add after:=ThisWorkbook.Sheets(.Count)
ActiveSheet.Name = "Temporary"
End With
Else
ThisWorkbook.Worksheets("Temporary").Cells.ClearContents
End If

Set fsread = CreateObject("Scripting.FileSystemObject")
TempRowCount = 1
First = True
Do
If First = True Then
Filename = Dir(Folder & "\*.csv")
First = False
Else
Filename = Dir()
End If
If Filename <> "" Then
'open files
Set fread = fsread.GetFile(Folder & "\" & Filename)
Set tsread = fread.OpenAsTextStream(ForReading, TristateUseDefault)

Do While tsread.atendofstream = False

Inputline = tsread.Readline

'extract comma seperated data
For i = 1 To 11
If i < 11 Then
CommaPosition = InStr(Inputline, ",")
If CommaPosition > 0 Then
data = Trim(Left(Inputline, CommaPosition - 1))
Inputline = Mid(Inputline, CommaPosition + 1)
field(i) = data
Else
field(i) = ""
End If
Else
field(i) = Trim(Inputline)
End If
Next i
If JobNumber = Val(field(7)) Then

'convert data to a serial format
NewDate = field(1)
NewYear = Val(Left(NewDate, 4))
NewDate = Mid(NewDate, 6)
NewMonth = Val(Left(NewDate, InStr(NewDate, "/") - 1))
NewDay = Val(Mid(NewDate, InStr(NewDate, "/") + 1))
field(1) = DateSerial(NewYear, NewMonth, NewDay)
For i = 1 To 11
With ThisWorkbook.Sheets("Temporary")
.Cells(TempRowCount, i) = field(i)
End With
Next i
If TempRowCount = Rows.Count Then
Call movedata
ThisWorkbook.Worksheets("Temporary").Cells.ClearContents
TempRowCount = 1
Else
TempRowCount = TempRowCount + 1
End If
End If
Loop

tsread.Close
End If
Loop While Filename <> ""
If Not IsEmpty(ThisWorkbook.Worksheets("Temporary").Range("A1")) Then
Call movedata
End If
End Sub
Sub movedata()
With ThisWorkbook.Sheets("Temporary")

LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
'Sort by date
.Range("A1:K" & LastRow).Sort _
Key1:=.Range("A1"), _
Order1:=xlAscending, _
Header:=xlGuess, _
DataOption1:=xlSortNormal

'move data to sheets by date
NewDate = .Range("A1")
StrDate = Year(NewDate) & "_" & Month(NewDate) & "_" & Day(NewDate)
NewRowCount = Findsheet(StrDate)

RowCount = 1
Do While .Range("A" & RowCount) <> ""
.Rows(RowCount).Copy Destination:= _
ThisWorkbook.Sheets(StrDate).Rows(NewRowCount)
NewRowCount = NewRowCount + 1
If .Range("A" & RowCount) <> .Range("A" & RowCount + 1) Then
If .Range("A" & RowCount + 1) <> "" Then
NewDate = .Range("A" & RowCount + 1)
StrDate = Year(NewDate) & "_" & Month(NewDate) & "_" &
Day(NewDate)
NewRowCount = Findsheet(StrDate)

End If
End If
RowCount = RowCount + 1
Loop
End With
End Sub

Function Findsheet(StrDate) As Integer

'check if worksheet exists
Found = False
For Each wbk In ThisWorkbook.Sheets
If wbk.Name = StrDate Then
Found = True
Exit For
End If
Next wbk

If Found = True Then
LastRow = wbk.Cells(Rows.Count, "A").End(xlUp).Row
Findsheet = LastRow + 1
Else
Findsheet = 1
ThisWorkbook.Sheets.Add _
after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = StrDate
End If

End Function






...

read more >>- Hide quoted text -

- Show quoted text -

Thanks for that. That works fine if I have less than 65 536 rows of
data, but for 65 536 rows or greater it throws up the error:

'Run time error '1004' Application defined object or object define
error


on row:

If .Range("A" & RowCount) <> .Range("A" & RowCount + 1) Then

Any ideas?

Also once the data is in the sheets, I want to be able to plot a line
graph of the data. Currently I am doing this using one chart for each
sheet and dynamic ranges etc for each sheet. However is there a way I
can just have one chart on a seperate worksheet say 'graph output' and
from this and select which data (i.e. which date sheet) is displayed
on the graph using a drop down menu?

Thanks for all your help,

Regards

Joseph Crabtree

 

[Joel]

I didn't test for the 65,536 condition. After I sent the solution yesterday
I was wondering what happens when 65,536 occurs. The solution is simple,
stop the code at 65,535 instead of 536 and leave the last row of worksheet
temporary blank.

from:
If TempRowCount = Rows.Count Then
to:
If TempRowCount = (Rows.Count - 1) Then

Rows.count is a excel constant that is equal to 65,536.

 

[joecrabtree]

I didn't test for the 65,536 condition. After I sent the solution yesterday
I was wondering what happens when 65,536 occurs. The solution is simple,
stop the code at 65,535 instead of 536 and leave the last row of worksheet
temporary blank.

from:
If TempRowCount = Rows.Count Then
to:
If TempRowCount = (Rows.Count - 1) Then

Rows.count is a excel constant that is equal to 65,536.





...

read more >>- Hide quoted text -

- Show quoted text -

That works now apart from : overflow error at:

Findsheet = LastRow + 1

Sorry to be a pain. Anything else i need to change?

Thanks

Joe

 

[Joel]

I think the problem is with the defintion of findsheet. Interger limit is
1/2 65,536 because integers they are both positive and negative. I think we
need to make it a long as shown below.
You aren't being a pain. it was my fault for not fully testing the code
uder every condition.

from
Function Findsheet(StrDate) As Integer
to
Function Findsheet(StrDate) As Long

 

[Joel]

Here is your answer to your plotting question

Create a table for the chart on the same page as the chart. Then use a
formula similar to the one below for each cell in the table use to chart the
data

=INDIRECT(ADDRESS(1,2,1,1,A1))

A1 is the drop down cell containing the sheet name
The first parameter is the row number where the data is located
The 2 is the column where the data is located.

If the chart table is 4 cells A1:B2 and the same range is on each sheet then
you would have for formlas. E8 is the dropdown cell locationm

A1: =INDIRECT(ADDRESS(1,1,1,1,E8))
B1: =INDIRECT(ADDRESS(1,2,1,1,E8))
A2: =INDIRECT(ADDRESS(2,1,1,1,E8))
A2: =INDIRECT(ADDRESS(2,2,1,1,E8))

The plot these four cells. Changing the dropdown box will get the data from
the correctt worksheet.




A1

 

[joecrabtree]

Here is your answer to your plotting question

Create a table for the chart on the same page as the chart. Then use a
formula similar to the one below for each cell in the table use to chart the
data

=INDIRECT(ADDRESS(1,2,1,1,A1))

A1 is the drop down cell containing the sheet name
The first parameter is the row number where the data is located
The 2 is the column where the data is located.

If the chart table is 4 cells A1:B2 and the same range is on each sheet then
you would have for formlas. E8 is the dropdown cell locationm

A1: =INDIRECT(ADDRESS(1,1,1,1,E8))
B1: =INDIRECT(ADDRESS(1,2,1,1,E8))
A2: =INDIRECT(ADDRESS(2,1,1,1,E8))
A2: =INDIRECT(ADDRESS(2,2,1,1,E8))

The plot these four cells. Changing the dropdown box will get the data from
the correctt worksheet.

A1





...

read more >>- Hide quoted text -

- Show quoted text -

Hi

I have realised what the problem is. For any one day there can be more
than 65,536 lines of data, so when it labels the sheet for example
2008_8_3, it then trys to create another sheet with the same title for
the rest of the data lines above 65,536, and throws up an error. I
eventually want to plot this data. So as the maximum points on one
chart is 32,000, is there any way to split the temporary sheet after
32000 rows of data. If the date is still the same then it would split
the data over multiple sheets i.e. 20080803_1 then 20080803_2 etc?

Is there any way to do this?

Thanks for your help,

Regards

Joseph Crabtree

 

[joecrabtree]

Hi

I have realised what the problem is. For any one day there can be
more
than 65,536 lines of data, so when it labels the sheet for example
2008_8_3, it then trys to create another sheet with the same title
for
the rest of the data lines above 65,536, and throws up an error. I
eventually want to plot this data. So as the maximum points on one
chart is 32,000, is there any way to split the temporary sheet after
32000 rows of data. If the date is still the same then it would split
the data over multiple sheets i.e. 20080803_1 then 20080803_2 etc?


Is there any way to do this?


Thanks for your help,


Regards


Joseph Crabtree

 

[Joel]

try the code below. I tested it only for a very simple case. Don't know if
there will be failures when you get to very large input data. I not used to
working with worksheets with this amount of data.

there are two places in the code I testr for 32000. didn't know if you
wanted the pages to end at 32000 or 32768.

I didn't chnage the size of the temporary page. Instead I tested the sheets
with dates to see if they exceeded 32000.

Sub GetFurnaceData()

Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const Folder = "C:\temp\test"
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Const JobNumber = 35900
Dim field(11)

'check if temporary worksheet exists
Found = False
For Each sht In ThisWorkbook.Sheets
If sht.Name = "Temporary" Then
Found = True
Exit For
End If
Next sht

If Found = False Then
With ThisWorkbook.Sheets
.Add after:=ThisWorkbook.Sheets(.Count)
ActiveSheet.Name = "Temporary"
End With
Else
ThisWorkbook.Worksheets("Temporary").Cells.ClearContents
End If


Set fsread = CreateObject("Scripting.FileSystemObject")
TempRowCount = 1
First = True
Do
If First = True Then
Filename = Dir(Folder & "\*.csv")
First = False
Else
Filename = Dir()
End If
If Filename <> "" Then
'open files
Set fread = fsread.GetFile(Folder & "\" & Filename)
Set tsread = fread.OpenAsTextStream(ForReading, TristateUseDefault)

Do While tsread.atendofstream = False

Inputline = tsread.Readline

'extract comma seperated data
For i = 1 To 11
If i < 11 Then
CommaPosition = InStr(Inputline, ",")
If CommaPosition > 0 Then
data = Trim(Left(Inputline, CommaPosition - 1))
Inputline = Mid(Inputline, CommaPosition + 1)
field(i) = data
Else
field(i) = ""
End If
Else
field(i) = Trim(Inputline)
End If
Next i
If JobNumber = Val(field(7)) Then

'convert data to a serial format
NewDate = field(1)
NewYear = Val(Left(NewDate, 4))
NewDate = Mid(NewDate, 6)
NewMonth = Val(Left(NewDate, InStr(NewDate, "/") - 1))
NewDay = Val(Mid(NewDate, InStr(NewDate, "/") + 1))
field(1) = DateSerial(NewYear, NewMonth, NewDay)
For i = 1 To 11
With ThisWorkbook.Sheets("Temporary")
.Cells(TempRowCount, i) = field(i)
End With
Next i
If TempRowCount = Rows.Count - 1 Then
Call movedata
ThisWorkbook.Worksheets("Temporary").Cells.ClearContents
TempRowCount = 1
Else
TempRowCount = TempRowCount + 1
End If
End If
Loop

tsread.Close
End If
Loop While Filename <> ""
If Not IsEmpty(ThisWorkbook.Worksheets("Temporary").Range("A1")) Then
Call movedata
End If
End Sub
Sub movedata()
With ThisWorkbook.Sheets("Temporary")

LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
'Sort by date
.Range("A1:K" & LastRow).Sort _
Key1:=.Range("A1"), _
Order1:=xlAscending, _
Header:=xlGuess, _
DataOption1:=xlSortNormal

'move data to sheets by date
NewDate = .Range("A1")
StrDate = Year(NewDate) & "_" & Month(NewDate) & "_" & Day(NewDate)
NewRowCount = Findsheet(StrDate, Sheetname)

RowCount = 1
Do While .Range("A" & RowCount) <> ""
If NewRowCount > 32000 Then
NewRowCount = Findsheet(StrDate, Sheetname)
End If
.Rows(RowCount).Copy Destination:= _
ThisWorkbook.Sheets(Sheetname).Rows(NewRowCount)
NewRowCount = NewRowCount + 1
If .Range("A" & RowCount) <> .Range("A" & RowCount + 1) Then
If .Range("A" & RowCount + 1) <> "" Then
NewDate = .Range("A" & RowCount + 1)
StrDate = Year(NewDate) & "_" & Month(NewDate) & "_" & _
Day(NewDate)
NewRowCount = Findsheet(StrDate, Sheetname)

End If
End If
RowCount = RowCount + 1
Loop
End With
End Sub

Function Findsheet(StrDate, ByRef Sheetname) As Long

'check if worksheet exists
Found = False
sheetnumber = 0
For Each wbk In ThisWorkbook.Sheets
If InStr(wbk.Name, StrDate) Then
Found = True
newnumber = Mid(wbk.Name, InStr(wbk.Name, "(") + 1)
newnumber = Val(Left(wbk.Name, InStr(wbk.Name, ")") - 1))
If newnumber > sheetnumber Then
sheetnumber = newnumber
End If
End If
Next wbk

If Found = True Then
Sheetname = StrDate & "(" & sheetnumber & ")"
With ThisWorkbook.Sheets(Sheetname)
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
If LastRow > 32000 Then
ThisWorkbook.Sheets.Add _
after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = StrDate & "(" & (sheetnumber + 1) & ")"
Sheetname = ActiveSheet.Name
Findsheet = 1
Else
Findsheet = LastRow + 1
End If
End With
Else
Findsheet = 1
ThisWorkbook.Sheets.Add _
after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = StrDate & "(1)"
Sheetname = ActiveSheet.Name
End If

End Function

 

[Joel]

I did some addional checking on the code and found 1 line wrong. Make the
following change.

from:
newnumber = Val(Left(wbk.Name, InStr(wbk.Name, ")") - 1))
to:
newnumber = Val(Left(newnumber, InStr(newnumber, ")") - 1))

 

[joecrabtree]

Thanks for that. That works great. Brilliant.

Theres just a few more things:

1 - Can the code be modified at the start so that the user can select
where to find the folder containing that data. I.e brings up an open
dialogue box. It would then run the macro as usual.

2 - Once it searchs for the part number - is it possible to display
the dates of all the text files that contain the data, eg: the user
searchs for 35900 it would return the dates 05112007, 06112007 etc
etc. Using this output it would then prompt the user select the dates
required that they want the data imported from eg just 05112007, and
then imports the data as per the macro.

I don't know if excel is capable of point number 2?

Thanks so much for your help,

regards

joseph Crabtree

 

[Joel]

The code below was modified bring up a text box to select a directory. It
actually requires the user to select a file, but will open every file in the
directory.

It is possible to have a user select a date, but you don't know the date(s)
until you open every file. To search evvery file for every date takes time
which means the selection box can't come up until after this process is
complete. then you would havve to again have to re-open every file and
extract the data.

I could have the user input a range of dates before opening up a file. Is
this what you want?

Sub GetFurnaceData()

Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Const JobNumber = 35900
Dim field(11)

Folder = "C:\temp\test"
Newfolder = Application.GetOpenFilename("CSV (*.csv),*.csv")
If Not Newfolder = False Then
Folder = ""
Do While InStr(Newfolder, "\") > 0
Folder = Folder & Left(Newfolder, InStr(Newfolder, "\"))
Newfolder = Mid(Newfolder, InStr(Newfolder, "\") + 1)
Loop
'remove last character which is a \
Folder = Left(Folder, Len(Folder) - 1)
End If
'check if temporary worksheet exists
Found = False
For Each sht In ThisWorkbook.Sheets
If sht.Name = "Temporary" Then
Found = True
Exit For
End If
Next sht

If Found = False Then
With ThisWorkbook.Sheets
.Add after:=ThisWorkbook.Sheets(.Count)
ActiveSheet.Name = "Temporary"
End With
Else
ThisWorkbook.Worksheets("Temporary").Cells.ClearContents
End If


Set fsread = CreateObject("Scripting.FileSystemObject")
TempRowCount = 1
First = True
Do
If First = True Then
Filename = Dir(Folder & "\*.csv")
First = False
Else
Filename = Dir()
End If
If Filename <> "" Then
'open files
Set fread = fsread.GetFile(Folder & "\" & Filename)
Set tsread = fread.OpenAsTextStream(ForReading, TristateUseDefault)

Do While tsread.atendofstream = False

Inputline = tsread.Readline

'extract comma seperated data
For i = 1 To 11
If i < 11 Then
CommaPosition = InStr(Inputline, ",")
If CommaPosition > 0 Then
data = Trim(Left(Inputline, CommaPosition - 1))
Inputline = Mid(Inputline, CommaPosition + 1)
field(i) = data
Else
field(i) = ""
End If
Else
field(i) = Trim(Inputline)
End If
Next i
If JobNumber = Val(field(7)) Then

'convert data to a serial format
NewDate = field(1)
NewYear = Val(Left(NewDate, 4))
NewDate = Mid(NewDate, 6)
NewMonth = Val(Left(NewDate, InStr(NewDate, "/") - 1))
NewDay = Val(Mid(NewDate, InStr(NewDate, "/") + 1))
field(1) = DateSerial(NewYear, NewMonth, NewDay)
For i = 1 To 11
With ThisWorkbook.Sheets("Temporary")
.Cells(TempRowCount, i) = field(i)
End With
Next i
If TempRowCount = Rows.Count - 1 Then
Call movedata
ThisWorkbook.Worksheets("Temporary").Cells.ClearContents
TempRowCount = 1
Else
TempRowCount = TempRowCount + 1
End If
End If
Loop

tsread.Close
End If
Loop While Filename <> ""
If Not IsEmpty(ThisWorkbook.Worksheets("Temporary").Range("A1")) Then
Call movedata
End If
End Sub
Sub movedata()
With ThisWorkbook.Sheets("Temporary")

LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
'Sort by date
.Range("A1:K" & LastRow).Sort _
Key1:=.Range("A1"), _
Order1:=xlAscending, _
Header:=xlGuess, _
DataOption1:=xlSortNormal

'move data to sheets by date
NewDate = .Range("A1")
StrDate = Year(NewDate) & "_" & Month(NewDate) & "_" & Day(NewDate)
NewRowCount = Findsheet(StrDate, Sheetname)

RowCount = 1
Do While .Range("A" & RowCount) <> ""
If NewRowCount > 32000 Then
NewRowCount = Findsheet(StrDate, Sheetname)
End If
.Rows(RowCount).Copy Destination:= _
ThisWorkbook.Sheets(Sheetname).Rows(NewRowCount)
NewRowCount = NewRowCount + 1
If .Range("A" & RowCount) <> .Range("A" & RowCount + 1) Then
If .Range("A" & RowCount + 1) <> "" Then
NewDate = .Range("A" & RowCount + 1)
StrDate = Year(NewDate) & "_" & Month(NewDate) & "_" & _
Day(NewDate)
NewRowCount = Findsheet(StrDate, Sheetname)

End If
End If
RowCount = RowCount + 1
Loop
End With
End Sub

Function Findsheet(StrDate, ByRef Sheetname) As Long

'check if worksheet exists
Found = False
sheetnumber = 0
For Each wbk In ThisWorkbook.Sheets
If InStr(wbk.Name, StrDate) Then
Found = True
newnumber = Mid(wbk.Name, InStr(wbk.Name, "(") + 1)
newnumber = Val(Left(newnumber, InStr(newnumber, ")") - 1))
If newnumber > sheetnumber Then
sheetnumber = newnumber
End If
End If
Next wbk

If Found = True Then
Sheetname = StrDate & "(" & sheetnumber & ")"
With ThisWorkbook.Sheets(Sheetname)
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
If LastRow > 32000 Then
ThisWorkbook.Sheets.Add _
after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = StrDate & "(" & (sheetnumber + 1) & ")"
Sheetname = ActiveSheet.Name
Findsheet = 1
Else
Findsheet = LastRow + 1
End If
End With
Else
Findsheet = 1
ThisWorkbook.Sheets.Add _
after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = StrDate & "(1)"
Sheetname = ActiveSheet.Name
End If

End Function

 

[joecrabtree]

If you could help me with the user selecting the dates to extract data
from that would be great.


Thanks allot.

Joe

 

[joecrabtree]

Sorry maybe i wasn't very clear in my last post. I would actually like
the user to select which folder the files are in insstead of it being
'hard wired' to Folder = "C:\temp\test" .

Is this possible?

Thanks

Joe Crabtree

 

[Joel]

Does this help?

Sub GetFurnaceData()

Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Const JobNumber = 35900
Dim field(11)

Folder = "C:\temp\test"
Newfolder = Application.GetOpenFilename("CSV (*.csv),*.csv")
If Not Newfolder = False Then
Folder = ""
Do While InStr(Newfolder, "\") > 0
Folder = Folder & Left(Newfolder, InStr(Newfolder, "\"))
Newfolder = Mid(Newfolder, InStr(Newfolder, "\") + 1)
Loop
'remove last character which is a \
Folder = Left(Folder, Len(Folder) - 1)
End If

'get start and end date
GoodDate = False
Do While GoodDate = False
StartDateStr = InputBox("Enter Start Date (YYYYMMDD: ")
NewYear = Left(StartDateStr, 4)
NewMonth = Mid(StartDateStr, 5, 2)
NewDay = Mid(StartDateStr, 7, 2)
If IsNumeric(NewYear) And IsNumeric(NewMonth) And _
IsNumeric(NewDay) Then

NewYear = Val(NewYear)
NewMonth = Val(NewMonth)
NewDay = Val(NewDay)

If (NewYear >= 1900) And _
(NewMonth >= 1) And (NewMonth <= 12) And _
(NewDay >= 1) And (NewDay <= 31) Then

StartDate = DateSerial(NewYear, NewMonth, NewDay)
GoodDate = True
End If
End If
Loop

'get end date
GoodDate = False
Do While GoodDate = False
EndDateStr = InputBox("Enter End Date (YYYYMMDD: ")
NewYear = Left(EndDateStr, 4)
NewMonth = Mid(EndDateStr, 5, 2)
NewDay = Mid(EndDateStr, 7, 2)
If IsNumeric(NewYear) And IsNumeric(NewMonth) And _
IsNumeric(NewDay) Then

NewYear = Val(NewYear)
NewMonth = Val(NewMonth)
NewDay = Val(NewDay)

If (NewYear >= 1900) And _
(NewMonth >= 1) And (NewMonth <= 12) And _
(NewDay >= 1) And (NewDay <= 31) Then

EndDate = DateSerial(NewYear, NewMonth, NewDay)
GoodDate = True
End If
End If
Loop


'check if temporary worksheet exists
Found = False
For Each sht In ThisWorkbook.Sheets
If sht.Name = "Temporary" Then
Found = True
Exit For
End If
Next sht

If Found = False Then
With ThisWorkbook.Sheets
.Add after:=ThisWorkbook.Sheets(.Count)
ActiveSheet.Name = "Temporary"
End With
Else
ThisWorkbook.Worksheets("Temporary").Cells.ClearContents
End If


Set fsread = CreateObject("Scripting.FileSystemObject")
TempRowCount = 1
First = True
Do
If First = True Then
Filename = Dir(Folder & "\*.csv")
First = False
Else
Filename = Dir()
End If
If Filename <> "" Then
'open files
Set fread = fsread.GetFile(Folder & "\" & Filename)
Set tsread = fread.OpenAsTextStream(ForReading, TristateUseDefault)

Do While tsread.atendofstream = False

Inputline = tsread.Readline

'extract comma seperated data
For i = 1 To 11
If i < 11 Then
CommaPosition = InStr(Inputline, ",")
If CommaPosition > 0 Then
data = Trim(Left(Inputline, CommaPosition - 1))
Inputline = Mid(Inputline, CommaPosition + 1)
field(i) = data
Else
field(i) = ""
End If
Else
field(i) = Trim(Inputline)
End If
Next i
If JobNumber = Val(field(7)) Then

'convert data to a serial format
NewDate = field(1)
NewYear = Val(Left(NewDate, 4))
NewDate = Mid(NewDate, 6)
NewMonth = Val(Left(NewDate, InStr(NewDate, "/") - 1))
NewDay = Val(Mid(NewDate, InStr(NewDate, "/") + 1))
field(1) = DateSerial(NewYear, NewMonth, NewDay)
If (field(1) >= StartDate) And (field(1) <= EndDate) Then

For i = 1 To 11
With ThisWorkbook.Sheets("Temporary")
.Cells(TempRowCount, i) = field(i)
End With
Next i
If TempRowCount = Rows.Count - 1 Then
Call movedata
ThisWorkbook.Worksheets("Temporary").Cells.ClearContents
TempRowCount = 1
Else
TempRowCount = TempRowCount + 1
End If
End If
End If
Loop

tsread.Close
End If
Loop While Filename <> ""
If Not IsEmpty(ThisWorkbook.Worksheets("Temporary").Range("A1")) Then
Call movedata
End If
End Sub
Sub movedata()
With ThisWorkbook.Sheets("Temporary")

LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
'Sort by date
.Range("A1:K" & LastRow).Sort _
Key1:=.Range("A1"), _
Order1:=xlAscending, _
Header:=xlGuess, _
DataOption1:=xlSortNormal

'move data to sheets by date
NewDate = .Range("A1")
StrDate = Year(NewDate) & "_" & Month(NewDate) & "_" & Day(NewDate)
NewRowCount = Findsheet(StrDate, Sheetname)

RowCount = 1
Do While .Range("A" & RowCount) <> ""
If NewRowCount > 32000 Then
NewRowCount = Findsheet(StrDate, Sheetname)
End If
.Rows(RowCount).Copy Destination:= _
ThisWorkbook.Sheets(Sheetname).Rows(NewRowCount)
NewRowCount = NewRowCount + 1
If .Range("A" & RowCount) <> .Range("A" & RowCount + 1) Then
If .Range("A" & RowCount + 1) <> "" Then
NewDate = .Range("A" & RowCount + 1)
StrDate = Year(NewDate) & "_" & Month(NewDate) & "_" & _
Day(NewDate)
NewRowCount = Findsheet(StrDate, Sheetname)

End If
End If
RowCount = RowCount + 1
Loop
End With
End Sub

Function Findsheet(StrDate, ByRef Sheetname) As Long

'check if worksheet exists
Found = False
sheetnumber = 0
For Each wbk In ThisWorkbook.Sheets
If InStr(wbk.Name, StrDate) Then
Found = True
newnumber = Mid(wbk.Name, InStr(wbk.Name, "(") + 1)
newnumber = Val(Left(newnumber, InStr(newnumber, ")") - 1))
If newnumber > sheetnumber Then
sheetnumber = newnumber
End If
End If
Next wbk

If Found = True Then
Sheetname = StrDate & "(" & sheetnumber & ")"
With ThisWorkbook.Sheets(Sheetname)
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
If LastRow > 32000 Then
ThisWorkbook.Sheets.Add _
after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = StrDate & "(" & (sheetnumber + 1) & ")"
Sheetname = ActiveSheet.Name
Findsheet = 1
Else
Findsheet = LastRow + 1
End If
End With
Else
Findsheet = 1
ThisWorkbook.Sheets.Add _
after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = StrDate & "(1)"
Sheetname = ActiveSheet.Name
End If

End Function