Create a list from offset data

[Jim G]

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.

 

[Joel]

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]

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.

 

[Joel]

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]

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 G]

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

 

[Joel]

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]

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

 

[Joel]

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]

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.