|
Data search and extraction from multiple text files query
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_Po sition,Clamp_Pressure,Current_Job,Toolslide_Positi on,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 |
Data search and extraction from multiple text files query
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.ClearCo ntents 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.Cou nt) 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.Cou nt) 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" wrote: 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_Po sition,Clamp_Pressure,Current_Job,Toolslide_Positi on,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 |
Data search and extraction from multiple text files query
On Nov 14, 5:20 pm, Joel wrote:
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.ClearCo ntents 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.Cou nt) 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.Cou nt) 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" wrote: 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_Po sition,Clamp_Pressure,Cur-rent_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- Hide quoted text - - 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 |
Data search and extraction from multiple text files query
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" wrote: On Nov 14, 5:20 pm, Joel wrote: 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.ClearCo ntents 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.Cou nt) 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.Cou nt) 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" wrote: 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_Po sition,Clamp_Pressure,Cur-rent_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- Hide quoted text - - 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 |
Data search and extraction from multiple text files query
Joel,
65536 rows are filled. Thanks Joe Joel wrote: 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" wrote: On Nov 14, 5:20 pm, Joel wrote: 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.ClearCo ntents 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.Cou nt) 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.Cou nt) 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" wrote: 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_Po sition,Clamp_Pressure,Cur-rent_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- Hide quoted text - - 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 |
Data search and extraction from multiple text files query
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.ClearCo ntents 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.ClearCo ntents 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.Cou nt) ActiveSheet.Name = StrDate End If End Function "joecrabtree" wrote: Joel, 65536 rows are filled. Thanks Joe Joel wrote: 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" wrote: On Nov 14, 5:20 pm, Joel wrote: 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.ClearCo ntents 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.Cou nt) 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.Cou nt) 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" wrote: 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_Po sition,Clamp_Pressure,Cur-rent_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- Hide quoted text - - 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 |
Data search and extraction from multiple text files query
On Nov 15, 5:14 pm, Joel wrote:
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.ClearCo ntents 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.ClearCo ntents 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.Cou nt) ActiveSheet.Name = StrDate End If End Function "joecrabtree" wrote: Joel, 65536 rows are filled. Thanks Joe Joel wrote: 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" wrote: On Nov 14, 5:20 pm, Joel wrote: 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.ClearCo ntents 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.Cou nt) 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.Cou nt) 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 ... 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 |
Data search and extraction from multiple text files query
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" wrote: On Nov 15, 5:14 pm, Joel wrote: 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.ClearCo ntents 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.ClearCo ntents 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.Cou nt) ActiveSheet.Name = StrDate End If End Function "joecrabtree" wrote: Joel, 65536 rows are filled. Thanks Joe Joel wrote: 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" wrote: On Nov 14, 5:20 pm, Joel wrote: 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.ClearCo ntents 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.Cou nt) 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 |
Data search and extraction from multiple text files query
On Nov 16, 2:07 pm, Joel wrote:
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" wrote: On Nov 15, 5:14 pm, Joel wrote: 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.ClearCo ntents 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.ClearCo ntents 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.Cou nt) ActiveSheet.Name = StrDate End If End Function "joecrabtree" wrote: Joel, 65536 rows are filled. Thanks Joe Joel wrote: 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" wrote: On Nov 14, 5:20 pm, Joel wrote: 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.ClearCo ntents 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, ... 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 |
Data search and extraction from multiple text files query
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 "joecrabtree" wrote: On Nov 16, 2:07 pm, Joel wrote: 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" wrote: On Nov 15, 5:14 pm, Joel wrote: 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.ClearCo ntents 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.ClearCo ntents 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.Cou nt) ActiveSheet.Name = StrDate End If End Function "joecrabtree" wrote: Joel, 65536 rows are filled. Thanks Joe Joel wrote: 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" wrote: On Nov 14, 5:20 pm, Joel wrote: 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.ClearCo ntents 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, |
Data search and extraction from multiple text files query
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" wrote: On Nov 16, 2:07 pm, Joel wrote: 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" wrote: On Nov 15, 5:14 pm, Joel wrote: 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.ClearCo ntents 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.ClearCo ntents 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.Cou nt) ActiveSheet.Name = StrDate End If End Function "joecrabtree" wrote: Joel, 65536 rows are filled. Thanks Joe Joel wrote: 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" wrote: On Nov 14, 5:20 pm, Joel wrote: 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.ClearCo ntents 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, |
Data search and extraction from multiple text files query
On 16 Nov, 20:08, Joel wrote:
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" wrote: On Nov 16, 2:07 pm, Joel wrote: 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" wrote: On Nov 15, 5:14 pm, Joel wrote: 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.ClearCo ntents 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.ClearCo ntents 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.Cou nt) ActiveSheet.Name = StrDate End If End Function "joecrabtree" wrote: Joel, 65536 rows are filled. Thanks Joe Joel wrote: 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" wrote: On Nov 14, 5:20 pm, Joel wrote: 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.ClearCo ntents 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 ... 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 |
Data search and extraction from multiple text files query
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 |
Data search and extraction from multiple text files query
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.ClearCo ntents 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.ClearCo ntents 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.Cou nt) 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.Cou nt) ActiveSheet.Name = StrDate & "(1)" Sheetname = ActiveSheet.Name End If End Function "joecrabtree" wrote: On 16 Nov, 20:08, Joel wrote: 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" wrote: On Nov 16, 2:07 pm, Joel wrote: 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" wrote: On Nov 15, 5:14 pm, Joel wrote: 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.ClearCo ntents 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.ClearCo ntents 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.Cou nt) ActiveSheet.Name = StrDate End If End Function "joecrabtree" wrote: Joel, 65536 rows are filled. Thanks Joe Joel wrote: 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" wrote: On Nov 14, 5:20 pm, Joel wrote: 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.ClearCo ntents 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 ... 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? |
Data search and extraction from multiple text files query
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)) "Joel" wrote: 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.ClearCo ntents 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.ClearCo ntents 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.Cou nt) 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.Cou nt) ActiveSheet.Name = StrDate & "(1)" Sheetname = ActiveSheet.Name End If End Function "joecrabtree" wrote: On 16 Nov, 20:08, Joel wrote: 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" wrote: On Nov 16, 2:07 pm, Joel wrote: 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" wrote: On Nov 15, 5:14 pm, Joel wrote: 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.ClearCo ntents 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 |
Data search and extraction from multiple text files query
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 |
Data search and extraction from multiple text files query
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.ClearCo ntents 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.ClearCo ntents 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.Cou nt) 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.Cou nt) ActiveSheet.Name = StrDate & "(1)" Sheetname = ActiveSheet.Name End If End Function "joecrabtree" wrote: 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 |
Data search and extraction from multiple text files query
If you could help me with the user selecting the dates to extract data
from that would be great. Thanks allot. Joe |
Data search and extraction from multiple text files query
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 |
Data search and extraction from multiple text files query
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.ClearCo ntents 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.ClearCo ntents 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.Cou nt) 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.Cou nt) ActiveSheet.Name = StrDate & "(1)" Sheetname = ActiveSheet.Name End If End Function "joecrabtree" wrote: If you could help me with the user selecting the dates to extract data from that would be great. Thanks allot. Joe |
Data search and extraction from multiple text files query
Thanks for all your help.
Just one more thing. Say I have a whole selection of these data files in a folder. Is it possible to search through them for the part number ( same as above ), and produce a list in Excel of the dates that contain this part number? EG: Part number 35900 would return: 01/11/2007 23/11/2007 etc ? Thanks Joseph Crabtree |
| All times are GMT +1. The time now is 05:31 PM. |
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com