Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.misc
|
|||
|
|||
Create a list from offset data
I have a data set that I download to excel and I need to select specifica
data to import into another programme. The raw data looks like this. Row Col A Col B Col C Col D Col E Col F 9 Date Shift Type SMU Start SMU End SMU Total Error Gap 10 11 12 Type: 45D (DUMPER) 13 14 15 Plant No: DT35 16 17 19/11/2007 DAY 4,904.00 4,977.00 73.00 0.00 This repeats for each plant number with the same row spacing. I would like to use a macro to create a unique list for each plant item ("DT35") followed by two commas (,,) the SMU End (Col D unformatted) comma and the date (DD/MM/YYYY). EG "DT35,,4977,19/11/2007 all in column A of a new sheet wthout headings. The lists will vary in length with each site. -- Jim |
#2
Posted to microsoft.public.excel.misc
|
|||
|
|||
Create a list from offset data
The code below works but may need some adjustments. From your data I can't
tell if the plant No is in column A or B. I also don't know if the date is in date format or just a string. Change the sheet names if necessary and try the code. Tell me the results and I will fix as necessary. Sub movedata() With Sheets("Sheet1") LastRow = Cells(Rows.Count, "A").End(xlUp).Row Sh1RowCount = 1 Sh2RowCount = 1 Do While Sh1RowCount <= LastRow ColAData = .Range("A" & Sh1RowCount) If InStr(ColAData, "Plant No:") 0 Then PlantNo = .Range("B" & Sh1RowCount) SMUEND = .Range("D" & (Sh1RowCount + 2)) NewDate = .Range("A" & (Sh1RowCount + 2)) StringData = PlantNo & ",," & SMUEND & _ "," & NewDate With Sheets("Sheet2") .Range("A" & Sh2RowCount) = StringData Sh2RowCount = Sh2RowCount + 1 End With End If Sh1RowCount = Sh1RowCount + 1 Loop End With End Sub "Jim G" wrote: I have a data set that I download to excel and I need to select specifica data to import into another programme. The raw data looks like this. Row Col A Col B Col C Col D Col E Col F 9 Date Shift Type SMU Start SMU End SMU Total Error Gap 10 11 12 Type: 45D (DUMPER) 13 14 15 Plant No: DT35 16 17 19/11/2007 DAY 4,904.00 4,977.00 73.00 0.00 This repeats for each plant number with the same row spacing. I would like to use a macro to create a unique list for each plant item ("DT35") followed by two commas (,,) the SMU End (Col D unformatted) comma and the date (DD/MM/YYYY). EG "DT35,,4977,19/11/2007 all in column A of a new sheet wthout headings. The lists will vary in length with each site. -- Jim |
#3
Posted to microsoft.public.excel.misc
|
|||
|
|||
Create a list from offset data
Thanks Joel,
The plant number is the string "Plant No: DT35" in column A. The date is formatted as date, but not necessary in the text file that will be exported. When i have the data arranged I will try to create a txt file with only the comma separated lines ready for import. I can probably handle this from my 'library' of code, however, if you have a standard method from this macro I'd be glad to have it. I'll test this on the morrow and get back to you with the result. Cheers and as always many thanks. -- Jim "Joel" wrote: The code below works but may need some adjustments. From your data I can't tell if the plant No is in column A or B. I also don't know if the date is in date format or just a string. Change the sheet names if necessary and try the code. Tell me the results and I will fix as necessary. Sub movedata() With Sheets("Sheet1") LastRow = Cells(Rows.Count, "A").End(xlUp).Row Sh1RowCount = 1 Sh2RowCount = 1 Do While Sh1RowCount <= LastRow ColAData = .Range("A" & Sh1RowCount) If InStr(ColAData, "Plant No:") 0 Then PlantNo = .Range("B" & Sh1RowCount) SMUEND = .Range("D" & (Sh1RowCount + 2)) NewDate = .Range("A" & (Sh1RowCount + 2)) StringData = PlantNo & ",," & SMUEND & _ "," & NewDate With Sheets("Sheet2") .Range("A" & Sh2RowCount) = StringData Sh2RowCount = Sh2RowCount + 1 End With End If Sh1RowCount = Sh1RowCount + 1 Loop End With End Sub "Jim G" wrote: I have a data set that I download to excel and I need to select specifica data to import into another programme. The raw data looks like this. Row Col A Col B Col C Col D Col E Col F 9 Date Shift Type SMU Start SMU End SMU Total Error Gap 10 11 12 Type: 45D (DUMPER) 13 14 15 Plant No: DT35 16 17 19/11/2007 DAY 4,904.00 4,977.00 73.00 0.00 This repeats for each plant number with the same row spacing. I would like to use a macro to create a unique list for each plant item ("DT35") followed by two commas (,,) the SMU End (Col D unformatted) comma and the date (DD/MM/YYYY). EG "DT35,,4977,19/11/2007 all in column A of a new sheet wthout headings. The lists will vary in length with each site. -- Jim |
#4
Posted to microsoft.public.excel.misc
|
|||
|
|||
Create a list from offset data
Here is modified code. I assumed in this new code the DT35 was in column A
(not B), tnherefore I had to extract the DT35 from the rest of the column A data. Sub movedata1() With Sheets("Sheet1") LastRow = .Cells(Rows.Count, "A").End(xlUp).Row Sh1RowCount = 1 Sh2RowCount = 1 Do While Sh1RowCount <= LastRow ColAData = .Range("A" & Sh1RowCount) If InStr(ColAData, "Plant No:") 0 Then 'extract the number only PlantNo = Trim(Mid(ColAData, InStr(ColAData, ":") + 1)) SMUEND = .Range("D" & (Sh1RowCount + 2)) NewDate = .Range("A" & (Sh1RowCount + 2)) StringData = PlantNo & ",," & SMUEND & _ "," & NewDate With Sheets("Sheet2") .Range("A" & Sh2RowCount) = StringData Sh2RowCount = Sh2RowCount + 1 End With End If Sh1RowCount = Sh1RowCount + 1 Loop End With End Sub "Jim G" wrote: I have a data set that I download to excel and I need to select specifica data to import into another programme. The raw data looks like this. Row Col A Col B Col C Col D Col E Col F 9 Date Shift Type SMU Start SMU End SMU Total Error Gap 10 11 12 Type: 45D (DUMPER) 13 14 15 Plant No: DT35 16 17 19/11/2007 DAY 4,904.00 4,977.00 73.00 0.00 This repeats for each plant number with the same row spacing. I would like to use a macro to create a unique list for each plant item ("DT35") followed by two commas (,,) the SMU End (Col D unformatted) comma and the date (DD/MM/YYYY). EG "DT35,,4977,19/11/2007 all in column A of a new sheet wthout headings. The lists will vary in length with each site. -- Jim |
#5
Posted to microsoft.public.excel.misc
|
|||
|
|||
Create a list from offset data
I've used this to open the file nominated by the user (the data file from
site). Unfortunately, the date formats change to serial when copied to Sheet "DATA". Is there a quick code addition to this that will coerce the date to DD/MM/YYYY before it's copied to Sheet "DATA". I have a macro that will do this but is seems overblown for this purpose. Jim Sub OpenSiteData() Dim Msg, Style, Title, Help, Ctxt, Response, MyString Msg = "Select ""YES"" to proceed to Open a Site Meter Data File, ""NO"" to CANCEL and view Current File only" Style = vbYesNoCancel + vbCritical + vbDefaultButton2 ' Define buttons. Title = "Open a New Ledger Data File " ' Define title. Response = MsgBox(Msg, Style, Title, Help, Ctxt) If Response = vbYes Then Dim myFileName As Variant Dim wkbk As Workbook Dim MyPath As String Dim sFilename As String Dim fExitDo As Boolean Dim sFileType As String 'only use if same file name used with extension Dim sFileOpen As String MyPath = "T:\" 'TEMP dir for testing ChDrive "T:\" 'TEMP drive for testing ChDir MyPath '---didn't seem to work on it's own- best with ChDrive as well sFilename = InputBox("Please Provide the Site Number Only") sFileOpen = MyPath & sFilename & ".xls" 'sFileOpen = MyPath & sFilename & sFileType & ".xls" 'only use if same file name used with extension fExitDo = False If sFilename = "" Then Exit Sub 'user hit cancel End If Set wkbk = Workbooks.Open(Filename:=sFileOpen) Else Exit Sub End If ActiveSheet.Cells.Select Selection.Copy Application.DisplayAlerts = False Windows("Site Data Template.xls").Activate Sheets("Data").Select Cells.Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wkbk.Close Savechanges = False Application.DisplayAlerts = True End Sub -- Jim "Joel" wrote: Here is modified code. I assumed in this new code the DT35 was in column A (not B), tnherefore I had to extract the DT35 from the rest of the column A data. Sub movedata1() With Sheets("Sheet1") LastRow = .Cells(Rows.Count, "A").End(xlUp).Row Sh1RowCount = 1 Sh2RowCount = 1 Do While Sh1RowCount <= LastRow ColAData = .Range("A" & Sh1RowCount) If InStr(ColAData, "Plant No:") 0 Then 'extract the number only PlantNo = Trim(Mid(ColAData, InStr(ColAData, ":") + 1)) SMUEND = .Range("D" & (Sh1RowCount + 2)) NewDate = .Range("A" & (Sh1RowCount + 2)) StringData = PlantNo & ",," & SMUEND & _ "," & NewDate With Sheets("Sheet2") .Range("A" & Sh2RowCount) = StringData Sh2RowCount = Sh2RowCount + 1 End With End If Sh1RowCount = Sh1RowCount + 1 Loop End With End Sub "Jim G" wrote: I have a data set that I download to excel and I need to select specifica data to import into another programme. The raw data looks like this. Row Col A Col B Col C Col D Col E Col F 9 Date Shift Type SMU Start SMU End SMU Total Error Gap 10 11 12 Type: 45D (DUMPER) 13 14 15 Plant No: DT35 16 17 19/11/2007 DAY 4,904.00 4,977.00 73.00 0.00 This repeats for each plant number with the same row spacing. I would like to use a macro to create a unique list for each plant item ("DT35") followed by two commas (,,) the SMU End (Col D unformatted) comma and the date (DD/MM/YYYY). EG "DT35,,4977,19/11/2007 all in column A of a new sheet wthout headings. The lists will vary in length with each site. -- Jim |
#6
Posted to microsoft.public.excel.misc
|
|||
|
|||
Create a list from offset data
Following from the previous post.
When the Sheet "DATA" is updated your "Movedata1()" macro is run on Worksheet_Change(ByVal Target As Range) I have used the code below that I copied from Chip Pearson to export the text from the Sheet "TEXT" to a file "Test.txt". Since your code adds the commas, I've removed the comma characters (assumed to be CHR (34)) because it was adding commas for the blank (unused) cells in Sheet "TEXT". I hope this hasn't any unforeseen consequences. The result is perfect and the text data is apended each time I open a new data file. Is there a way i could open several files (or a whole directory) at once and append one after the otehr until done and the data files closed? My objective is to have the user download all the site data files then run these macros in a template to create a single data file to upload the text file into our maintenance scheduling software. Currently the user manually copies all the plant data from each site files (dozens per week) to another excel file then saves the file as a CSV file ready for uploading, then spends the rest of the day looking for and correcting the typos when the file is rejected due to errors. I hope you don't mind the detail, I mention this to demonstrate the emense value you have provided and the extent of my appreciation. ----------------------------------------------------------- I call this with Chips: Sub DoTheExport() ExportToTextFile FName:="T:\Test.txt", Sep:=";", _ SelectionOnly:=False, AppendData:=True End Sub Chip Pearsons code: Public Sub ExportToTextFile(FName As String, _ Sep As String, SelectionOnly As Boolean, _ AppendData As Boolean) Dim WholeLine As String Dim FNum As Integer Dim RowNdx As Long Dim ColNdx As Integer Dim StartRow As Long Dim EndRow As Long Dim StartCol As Integer Dim EndCol As Integer Dim CellValue As String Sheets("Text").Select Application.ScreenUpdating = False On Error GoTo EndMacro: FNum = FreeFile If SelectionOnly = True Then With Selection StartRow = .Cells(1).Row StartCol = .Cells(1).Column EndRow = .Cells(.Cells.Count).Row EndCol = .Cells(.Cells.Count).Column End With Else With ActiveSheet.UsedRange StartRow = .Cells(1).Row StartCol = .Cells(1).Column EndRow = .Cells(.Cells.Count).Row EndCol = .Cells(.Cells.Count).Column End With End If If AppendData = True Then Open FName For Append Access Write As #FNum Else Open FName For Output Access Write As #FNum End If For RowNdx = StartRow To EndRow WholeLine = "" For ColNdx = StartCol To EndCol If Cells(RowNdx, ColNdx).Value = "" Then CellValue = "" 'Chr(34) & Chr(34) Else CellValue = Cells(RowNdx, ColNdx).Text End If WholeLine = WholeLine & CellValue & Sep Next ColNdx WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep)) Print #FNum, WholeLine Next RowNdx EndMacro: On Error GoTo 0 Application.ScreenUpdating = True Close #FNum End Sub -- Jim "Joel" wrote: Here is modified code. I assumed in this new code the DT35 was in column A (not B), tnherefore I had to extract the DT35 from the rest of the column A data. Sub movedata1() With Sheets("Sheet1") LastRow = .Cells(Rows.Count, "A").End(xlUp).Row Sh1RowCount = 1 Sh2RowCount = 1 Do While Sh1RowCount <= LastRow ColAData = .Range("A" & Sh1RowCount) If InStr(ColAData, "Plant No:") 0 Then 'extract the number only PlantNo = Trim(Mid(ColAData, InStr(ColAData, ":") + 1)) SMUEND = .Range("D" & (Sh1RowCount + 2)) NewDate = .Range("A" & (Sh1RowCount + 2)) StringData = PlantNo & ",," & SMUEND & _ "," & NewDate With Sheets("Sheet2") .Range("A" & Sh2RowCount) = StringData Sh2RowCount = Sh2RowCount + 1 End With End If Sh1RowCount = Sh1RowCount + 1 Loop End With End Sub "Jim G" wrote: I have a data set that I download to excel and I need to select specifica data to import into another programme. The raw data looks like this. Row Col A Col B Col C Col D Col E Col F 9 Date Shift Type SMU Start SMU End SMU Total Error Gap 10 11 12 Type: 45D (DUMPER) 13 14 15 Plant No: DT35 16 17 19/11/2007 DAY 4,904.00 4,977.00 73.00 0.00 This repeats for each plant number with the same row spacing. I would like to use a macro to create a unique list for each plant item ("DT35") followed by two commas (,,) the SMU End (Col D unformatted) comma and the date (DD/MM/YYYY). EG "DT35,,4977,19/11/2007 all in column A of a new sheet wthout headings. The lists will vary in length with each site. -- Jim |
#7
Posted to microsoft.public.excel.misc
|
|||
|
|||
Create a list from offset data
I received both of your posting. I thought it would be better to answer each
posting seperately. I don't think it is necessary to worry about the date being converted to serial. it is actually bettter. If you have the following Dim Mydate as Date Dim MyString as string Mydate = date '(11/21/07) MyString = "abc " NewString = MyString & Mydate the results is "abc 11/21/07" Excel automatically converts the serial date to string format. I going to start on the second posting. Little confusing. A double quote is Chr(34), a comma is Chr(44). See ASCII (1 - 127) in VBA help window. "Jim G" wrote: I've used this to open the file nominated by the user (the data file from site). Unfortunately, the date formats change to serial when copied to Sheet "DATA". Is there a quick code addition to this that will coerce the date to DD/MM/YYYY before it's copied to Sheet "DATA". I have a macro that will do this but is seems overblown for this purpose. Jim Sub OpenSiteData() Dim Msg, Style, Title, Help, Ctxt, Response, MyString Msg = "Select ""YES"" to proceed to Open a Site Meter Data File, ""NO"" to CANCEL and view Current File only" Style = vbYesNoCancel + vbCritical + vbDefaultButton2 ' Define buttons. Title = "Open a New Ledger Data File " ' Define title. Response = MsgBox(Msg, Style, Title, Help, Ctxt) If Response = vbYes Then Dim myFileName As Variant Dim wkbk As Workbook Dim MyPath As String Dim sFilename As String Dim fExitDo As Boolean Dim sFileType As String 'only use if same file name used with extension Dim sFileOpen As String MyPath = "T:\" 'TEMP dir for testing ChDrive "T:\" 'TEMP drive for testing ChDir MyPath '---didn't seem to work on it's own- best with ChDrive as well sFilename = InputBox("Please Provide the Site Number Only") sFileOpen = MyPath & sFilename & ".xls" 'sFileOpen = MyPath & sFilename & sFileType & ".xls" 'only use if same file name used with extension fExitDo = False If sFilename = "" Then Exit Sub 'user hit cancel End If Set wkbk = Workbooks.Open(Filename:=sFileOpen) Else Exit Sub End If ActiveSheet.Cells.Select Selection.Copy Application.DisplayAlerts = False Windows("Site Data Template.xls").Activate Sheets("Data").Select Cells.Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wkbk.Close Savechanges = False Application.DisplayAlerts = True End Sub -- Jim "Joel" wrote: Here is modified code. I assumed in this new code the DT35 was in column A (not B), tnherefore I had to extract the DT35 from the rest of the column A data. Sub movedata1() With Sheets("Sheet1") LastRow = .Cells(Rows.Count, "A").End(xlUp).Row Sh1RowCount = 1 Sh2RowCount = 1 Do While Sh1RowCount <= LastRow ColAData = .Range("A" & Sh1RowCount) If InStr(ColAData, "Plant No:") 0 Then 'extract the number only PlantNo = Trim(Mid(ColAData, InStr(ColAData, ":") + 1)) SMUEND = .Range("D" & (Sh1RowCount + 2)) NewDate = .Range("A" & (Sh1RowCount + 2)) StringData = PlantNo & ",," & SMUEND & _ "," & NewDate With Sheets("Sheet2") .Range("A" & Sh2RowCount) = StringData Sh2RowCount = Sh2RowCount + 1 End With End If Sh1RowCount = Sh1RowCount + 1 Loop End With End Sub "Jim G" wrote: I have a data set that I download to excel and I need to select specifica data to import into another programme. The raw data looks like this. Row Col A Col B Col C Col D Col E Col F 9 Date Shift Type SMU Start SMU End SMU Total Error Gap 10 11 12 Type: 45D (DUMPER) 13 14 15 Plant No: DT35 16 17 19/11/2007 DAY 4,904.00 4,977.00 73.00 0.00 This repeats for each plant number with the same row spacing. I would like to use a macro to create a unique list for each plant item ("DT35") followed by two commas (,,) the SMU End (Col D unformatted) comma and the date (DD/MM/YYYY). EG "DT35,,4977,19/11/2007 all in column A of a new sheet wthout headings. The lists will vary in length with each site. -- Jim |
#8
Posted to microsoft.public.excel.misc
|
|||
|
|||
Create a list from offset data
Hi Joel,
the date solution looks like it will solve the problem. I'll give it a go on the morrow and let you know how it goes. On the second posting, I wasn't sure what the character was other than it resulted in ,, on each blank row. By remarking them out it seemed to fix the problem and the text lines stops at the end of the data. I've since placed an instruction to clear the sheet before the new data is pasted because if the previous data was larger the remaining lines were duplicated in the text file. Other than that it works perfectly in my tests. I hope to have the final product save as named files in other locations on the server. Because of the risk of duplication if the macros are repeated I will look to create back up copies of the data files and delete the original files. Cheers Jim -- Jim "Joel" wrote: I received both of your posting. I thought it would be better to answer each posting seperately. I don't think it is necessary to worry about the date being converted to serial. it is actually bettter. If you have the following Dim Mydate as Date Dim MyString as string Mydate = date '(11/21/07) MyString = "abc " NewString = MyString & Mydate the results is "abc 11/21/07" Excel automatically converts the serial date to string format. I going to start on the second posting. Little confusing. A double quote is Chr(34), a comma is Chr(44). See ASCII (1 - 127) in VBA help window. "Jim G" wrote: I've used this to open the file nominated by the user (the data file from site). Unfortunately, the date formats change to serial when copied to Sheet "DATA". Is there a quick code addition to this that will coerce the date to DD/MM/YYYY before it's copied to Sheet "DATA". I have a macro that will do this but is seems overblown for this purpose. Jim Sub OpenSiteData() Dim Msg, Style, Title, Help, Ctxt, Response, MyString Msg = "Select ""YES"" to proceed to Open a Site Meter Data File, ""NO"" to CANCEL and view Current File only" Style = vbYesNoCancel + vbCritical + vbDefaultButton2 ' Define buttons. Title = "Open a New Ledger Data File " ' Define title. Response = MsgBox(Msg, Style, Title, Help, Ctxt) If Response = vbYes Then Dim myFileName As Variant Dim wkbk As Workbook Dim MyPath As String Dim sFilename As String Dim fExitDo As Boolean Dim sFileType As String 'only use if same file name used with extension Dim sFileOpen As String MyPath = "T:\" 'TEMP dir for testing ChDrive "T:\" 'TEMP drive for testing ChDir MyPath '---didn't seem to work on it's own- best with ChDrive as well sFilename = InputBox("Please Provide the Site Number Only") sFileOpen = MyPath & sFilename & ".xls" 'sFileOpen = MyPath & sFilename & sFileType & ".xls" 'only use if same file name used with extension fExitDo = False If sFilename = "" Then Exit Sub 'user hit cancel End If Set wkbk = Workbooks.Open(Filename:=sFileOpen) Else Exit Sub End If ActiveSheet.Cells.Select Selection.Copy Application.DisplayAlerts = False Windows("Site Data Template.xls").Activate Sheets("Data").Select Cells.Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wkbk.Close Savechanges = False Application.DisplayAlerts = True End Sub -- Jim "Joel" wrote: Here is modified code. I assumed in this new code the DT35 was in column A (not B), tnherefore I had to extract the DT35 from the rest of the column A data. Sub movedata1() With Sheets("Sheet1") LastRow = .Cells(Rows.Count, "A").End(xlUp).Row Sh1RowCount = 1 Sh2RowCount = 1 Do While Sh1RowCount <= LastRow ColAData = .Range("A" & Sh1RowCount) If InStr(ColAData, "Plant No:") 0 Then 'extract the number only PlantNo = Trim(Mid(ColAData, InStr(ColAData, ":") + 1)) SMUEND = .Range("D" & (Sh1RowCount + 2)) NewDate = .Range("A" & (Sh1RowCount + 2)) StringData = PlantNo & ",," & SMUEND & _ "," & NewDate With Sheets("Sheet2") .Range("A" & Sh2RowCount) = StringData Sh2RowCount = Sh2RowCount + 1 End With End If Sh1RowCount = Sh1RowCount + 1 Loop End With End Sub "Jim G" wrote: I have a data set that I download to excel and I need to select specifica data to import into another programme. The raw data looks like this. Row Col A Col B Col C Col D Col E Col F 9 Date Shift Type SMU Start SMU End SMU Total Error Gap 10 11 12 Type: 45D (DUMPER) 13 14 15 Plant No: DT35 16 17 19/11/2007 DAY 4,904.00 4,977.00 73.00 0.00 This repeats for each plant number with the same row spacing. I would like to use a macro to create a unique list for each plant item ("DT35") followed by two commas (,,) the SMU End (Col D unformatted) comma and the date (DD/MM/YYYY). EG "DT35,,4977,19/11/2007 all in column A of a new sheet wthout headings. The lists will vary in length with each site. -- Jim |
#9
Posted to microsoft.public.excel.misc
|
|||
|
|||
Create a list from offset data
I quickly modified some code from some other postings. This coded puts all
the data read on one worksheet. Modify Folder = "C:\temp\test" to be used as a default folder incase somebody hits canceled in the pop up menu. Sub GetCSVData() Const ForReading = 1, ForWriting = 2, ForAppending = 3 Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0 Set fsread = CreateObject("Scripting.FileSystemObject") 'default folder 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 Lastrow = Cells(Rows.Count, "A").End(xlUp).Row RowCount = Lastrow + 1First = 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 ColumnCount = 1 Do While InputLine < "" CommaPosition = InStr(InputLine, ",") If CommaPosition 0 Then data = Trim(Left(InputLine, CommaPosition - 1)) InputLine = Mid(InputLine, CommaPosition + 1) Else data = Trim(InputLine) InputLine = "" End If Cells(RowCount, ColumnCount) = data ColumnCount = ColumnCount + 1 Loop RowCount = RowCount + 1 Loop tsread.Close End If Loop While Filename < "" End Sub "Jim G" wrote: Following from the previous post. When the Sheet "DATA" is updated your "Movedata1()" macro is run on Worksheet_Change(ByVal Target As Range) I have used the code below that I copied from Chip Pearson to export the text from the Sheet "TEXT" to a file "Test.txt". Since your code adds the commas, I've removed the comma characters (assumed to be CHR (34)) because it was adding commas for the blank (unused) cells in Sheet "TEXT". I hope this hasn't any unforeseen consequences. The result is perfect and the text data is apended each time I open a new data file. Is there a way i could open several files (or a whole directory) at once and append one after the otehr until done and the data files closed? My objective is to have the user download all the site data files then run these macros in a template to create a single data file to upload the text file into our maintenance scheduling software. Currently the user manually copies all the plant data from each site files (dozens per week) to another excel file then saves the file as a CSV file ready for uploading, then spends the rest of the day looking for and correcting the typos when the file is rejected due to errors. I hope you don't mind the detail, I mention this to demonstrate the emense value you have provided and the extent of my appreciation. ----------------------------------------------------------- I call this with Chips: Sub DoTheExport() ExportToTextFile FName:="T:\Test.txt", Sep:=";", _ SelectionOnly:=False, AppendData:=True End Sub Chip Pearsons code: Public Sub ExportToTextFile(FName As String, _ Sep As String, SelectionOnly As Boolean, _ AppendData As Boolean) Dim WholeLine As String Dim FNum As Integer Dim RowNdx As Long Dim ColNdx As Integer Dim StartRow As Long Dim EndRow As Long Dim StartCol As Integer Dim EndCol As Integer Dim CellValue As String Sheets("Text").Select Application.ScreenUpdating = False On Error GoTo EndMacro: FNum = FreeFile If SelectionOnly = True Then With Selection StartRow = .Cells(1).Row StartCol = .Cells(1).Column EndRow = .Cells(.Cells.Count).Row EndCol = .Cells(.Cells.Count).Column End With Else With ActiveSheet.UsedRange StartRow = .Cells(1).Row StartCol = .Cells(1).Column EndRow = .Cells(.Cells.Count).Row EndCol = .Cells(.Cells.Count).Column End With End If If AppendData = True Then Open FName For Append Access Write As #FNum Else Open FName For Output Access Write As #FNum End If For RowNdx = StartRow To EndRow WholeLine = "" For ColNdx = StartCol To EndCol If Cells(RowNdx, ColNdx).Value = "" Then CellValue = "" 'Chr(34) & Chr(34) Else CellValue = Cells(RowNdx, ColNdx).Text End If WholeLine = WholeLine & CellValue & Sep Next ColNdx WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep)) Print #FNum, WholeLine Next RowNdx EndMacro: On Error GoTo 0 Application.ScreenUpdating = True Close #FNum End Sub -- Jim "Joel" wrote: Here is modified code. I assumed in this new code the DT35 was in column A (not B), tnherefore I had to extract the DT35 from the rest of the column A data. Sub movedata1() With Sheets("Sheet1") LastRow = .Cells(Rows.Count, "A").End(xlUp).Row Sh1RowCount = 1 Sh2RowCount = 1 Do While Sh1RowCount <= LastRow ColAData = .Range("A" & Sh1RowCount) If InStr(ColAData, "Plant No:") 0 Then 'extract the number only PlantNo = Trim(Mid(ColAData, InStr(ColAData, ":") + 1)) SMUEND = .Range("D" & (Sh1RowCount + 2)) NewDate = .Range("A" & (Sh1RowCount + 2)) StringData = PlantNo & ",," & SMUEND & _ "," & NewDate With Sheets("Sheet2") .Range("A" & Sh2RowCount) = StringData Sh2RowCount = Sh2RowCount + 1 End With End If Sh1RowCount = Sh1RowCount + 1 Loop End With End Sub "Jim G" wrote: I have a data set that I download to excel and I need to select specifica data to import into another programme. The raw data looks like this. Row Col A Col B Col C Col D Col E Col F 9 Date Shift Type SMU Start SMU End SMU Total Error Gap 10 11 12 Type: 45D (DUMPER) 13 14 15 Plant No: DT35 16 17 19/11/2007 DAY 4,904.00 4,977.00 73.00 0.00 This repeats for each plant number with the same row spacing. I would like to use a macro to create a unique list for each plant item ("DT35") followed by two commas (,,) the SMU End (Col D unformatted) comma and the date (DD/MM/YYYY). EG "DT35,,4977,19/11/2007 all in column A of a new sheet wthout headings. The lists will vary in length with each site. -- Jim |
#10
Posted to microsoft.public.excel.misc
|
|||
|
|||
Create a list from offset data
Hi Joel,
This code is fairly complex for my skill level and I'm having trouble following it. I couldn't work out where to place it in my workbook, other than as a module. When run the macro stopped at "Lastrow = Cells(Rows.Count, "A").End(xlUp).Row". However, the your amendment for date serial data worked well. I have a workable model where the data flows through the template and is not requried to be saved. The template has two sheets, Sheet("Text") and Sheet("Data"). To complete the project I would like to, (having saved all the data files from our site software into directory E:\SitePack\Export\Data\U032.xls (etc)) 1- have the data files opened one after the other (or selected as a range of files by the user) into the template, 2-the data converted to text (cumulative) into E:\SitePack\Import\Data\Meter Reading.txt (I have this working with users being prompted for individual file names). 3-the data files in E:\SitePack\Export\Data\U032.xls (etc), being backed up (or copied) to E:\SitePack\Export\Data\Backup then deleted from E:\SitePack\Export\Data\ to ensure they aren't accidentally used again. Thanks again for you help on this. -- Jim "Joel" wrote: I quickly modified some code from some other postings. This coded puts all the data read on one worksheet. Modify Folder = "C:\temp\test" to be used as a default folder incase somebody hits canceled in the pop up menu. Sub GetCSVData() Const ForReading = 1, ForWriting = 2, ForAppending = 3 Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0 Set fsread = CreateObject("Scripting.FileSystemObject") 'default folder 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 Lastrow = Cells(Rows.Count, "A").End(xlUp).Row RowCount = Lastrow + 1First = 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 ColumnCount = 1 Do While InputLine < "" CommaPosition = InStr(InputLine, ",") If CommaPosition 0 Then data = Trim(Left(InputLine, CommaPosition - 1)) InputLine = Mid(InputLine, CommaPosition + 1) Else data = Trim(InputLine) InputLine = "" End If Cells(RowCount, ColumnCount) = data ColumnCount = ColumnCount + 1 Loop RowCount = RowCount + 1 Loop tsread.Close End If Loop While Filename < "" End Sub "Jim G" wrote: Following from the previous post. When the Sheet "DATA" is updated your "Movedata1()" macro is run on Worksheet_Change(ByVal Target As Range) I have used the code below that I copied from Chip Pearson to export the text from the Sheet "TEXT" to a file "Test.txt". Since your code adds the commas, I've removed the comma characters (assumed to be CHR (34)) because it was adding commas for the blank (unused) cells in Sheet "TEXT". I hope this hasn't any unforeseen consequences. The result is perfect and the text data is apended each time I open a new data file. Is there a way i could open several files (or a whole directory) at once and append one after the otehr until done and the data files closed? My objective is to have the user download all the site data files then run these macros in a template to create a single data file to upload the text file into our maintenance scheduling software. Currently the user manually copies all the plant data from each site files (dozens per week) to another excel file then saves the file as a CSV file ready for uploading, then spends the rest of the day looking for and correcting the typos when the file is rejected due to errors. I hope you don't mind the detail, I mention this to demonstrate the emense value you have provided and the extent of my appreciation. ----------------------------------------------------------- I call this with Chips: Sub DoTheExport() ExportToTextFile FName:="T:\Test.txt", Sep:=";", _ SelectionOnly:=False, AppendData:=True End Sub Chip Pearsons code: Public Sub ExportToTextFile(FName As String, _ Sep As String, SelectionOnly As Boolean, _ AppendData As Boolean) Dim WholeLine As String Dim FNum As Integer Dim RowNdx As Long Dim ColNdx As Integer Dim StartRow As Long Dim EndRow As Long Dim StartCol As Integer Dim EndCol As Integer Dim CellValue As String Sheets("Text").Select Application.ScreenUpdating = False On Error GoTo EndMacro: FNum = FreeFile If SelectionOnly = True Then With Selection StartRow = .Cells(1).Row StartCol = .Cells(1).Column EndRow = .Cells(.Cells.Count).Row EndCol = .Cells(.Cells.Count).Column End With Else With ActiveSheet.UsedRange StartRow = .Cells(1).Row StartCol = .Cells(1).Column EndRow = .Cells(.Cells.Count).Row EndCol = .Cells(.Cells.Count).Column End With End If If AppendData = True Then Open FName For Append Access Write As #FNum Else Open FName For Output Access Write As #FNum End If For RowNdx = StartRow To EndRow WholeLine = "" For ColNdx = StartCol To EndCol If Cells(RowNdx, ColNdx).Value = "" Then CellValue = "" 'Chr(34) & Chr(34) Else CellValue = Cells(RowNdx, ColNdx).Text End If WholeLine = WholeLine & CellValue & Sep Next ColNdx WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep)) Print #FNum, WholeLine Next RowNdx EndMacro: On Error GoTo 0 Application.ScreenUpdating = True Close #FNum End Sub -- Jim "Joel" wrote: Here is modified code. I assumed in this new code the DT35 was in column A (not B), tnherefore I had to extract the DT35 from the rest of the column A data. Sub movedata1() With Sheets("Sheet1") LastRow = .Cells(Rows.Count, "A").End(xlUp).Row Sh1RowCount = 1 Sh2RowCount = 1 Do While Sh1RowCount <= LastRow ColAData = .Range("A" & Sh1RowCount) If InStr(ColAData, "Plant No:") 0 Then 'extract the number only PlantNo = Trim(Mid(ColAData, InStr(ColAData, ":") + 1)) SMUEND = .Range("D" & (Sh1RowCount + 2)) NewDate = .Range("A" & (Sh1RowCount + 2)) StringData = PlantNo & ",," & SMUEND & _ "," & NewDate With Sheets("Sheet2") .Range("A" & Sh2RowCount) = StringData Sh2RowCount = Sh2RowCount + 1 End With End If Sh1RowCount = Sh1RowCount + 1 Loop End With End Sub "Jim G" wrote: I have a data set that I download to excel and I need to select specifica data to import into another programme. The raw data looks like this. Row Col A Col B Col C Col D Col E Col F 9 Date Shift Type SMU Start SMU End SMU Total Error Gap 10 11 12 Type: 45D (DUMPER) 13 14 15 Plant No: DT35 16 17 19/11/2007 DAY 4,904.00 4,977.00 73.00 0.00 This repeats for each plant number with the same row spacing. I would like to use a macro to create a unique list for each plant item ("DT35") followed by two commas (,,) the SMU End (Col D unformatted) comma and the date (DD/MM/YYYY). EG "DT35,,4977,19/11/2007 all in column A of a new sheet wthout headings. The lists will vary in length with each site. -- Jim |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Create a List by formula from other data | Excel Worksheet Functions | |||
I do not have the List-create a list option on my data toolbar ?? | New Users to Excel | |||
Want to Create a List in Excel 2002; Don't see List in Data Menu? | Excel Discussion (Misc queries) | |||
How do I get LIST on the DATA menu bar-I need Create List | New Users to Excel | |||
Does Excel 2002 have a List>Create List option under Data? | Excel Discussion (Misc queries) |