Solved: Create Text files for each subject and Date

[CCkfm2000]

I have an excel spreadsheet with the following titles :dunno

Employee Number
DateAccredited(Date)
LastName
AccreditationTitle
FirstName
Entered on OLM

With over 500 bits of information

What I need is some macro that will read the data and save individual text files for each AccreditationTitle and Date

E.g.

318 Manual Handling Theory eLearning 03-Jun-2013
318 Medicine Management eLearning 04-Jun-2013
318 Prevention of Falls (Patients) eLearning 10-Jun-2013
318 Blood Transfusion eLearning 10-Jun-2013
318 Manual Handling Theory eLearning 04-Jun-2013


e.g.

File Name :- 318 Blood Transfusion eLearning 10-Jun-2013
Text File Data :- 45678912

File Name :- 318 Manual Handling Theory eLearning 03-Jun-2013
Text File Data :- 12345678
78784512

File Name :- 318 Manual Handling Theory eLearning 04-Jun-2013
Text File Data :- 75475478


Within each text file I need is the employee numbers only for the same date and AccreditationTitle.

Any idea where to start form.

i've attached the data file for reference.

Thanks for all the help :thumb

[Kenneth Hobs]

I don know where the data part comes from.

Did you want to export based on the filtered data or all data?

If you attach an example TXT file, that would help.

[CCkfm2000]

Thanks Kenneth,

The data comes from another system into excel then it's compiled into the attached spreadsheet (in my first post)

I need to export all data.

I've attached some examples text files for reference as requested in the zip file.

The AccreditationTitle consists of over 25 titles.

[Kenneth Hobs]

When I am solving a problem, I tend to use the brute strength method first. An ADO solution might be a bit more elegant.

While this code may seem extensive, simple concepts are used.

1. Unique Values in an Array
2. Getting folder name from the full path and name of a file
3. Writing a string to a text file
4. Finding all matches in a range (may be discontinuous)
5. Making an array from a discontinuous range
6. Making a scratch column (cleanup included at end)
7. How to do a multi-condition match

Normally, I put all Dim code into the first part of a Sub. In this case, I wrote it in sections to show you the concepts used.
You can also download the file and try it. Simply change the txtPath value if you don't want to use that workbook's path to store the txt files.

If the code runs a bit slow, in the production version, it can be sped up by a speedup routine that I posted to the kb.


Sub TitlesWithEmployeeNumbers()
' Create a Scratch Column for Unique Titles+Date and TXT filenames
Dim lr As Long, lc As Integer, c As Range, r As Range
lr = Cells(Rows.Count, "D").End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).Column
Set r = Range(Cells(2, lc + 1), Cells(lr, lc + 1))
For Each c In r
With c
.Value2 = Range("D" & .Row).Value2 & Format(Range("B" & .Row).Value, " dd-mmm-yyyy")
End With
Next c

' Put Unique Titles+Dates into array vRange:
Dim vRange As Variant
vRange = UniqueValues(r)

' Create TXT files with Employee number for each unique Title+Date
Dim txtPath As String, v As Variant, f As Range, s As String, a() As Variant
txtPath = ThisWorkbook.Path
For Each v In vRange
Set f = FoundRanges(r, CStr(v))
Set f = f.Offset(0, lc * -1)
a() = rList(f)
StrToTXTFile txtPath & "\" & v & ".txt", Join(a, vbCrLf)
Next v

' Cleanup
r.ClearContents
End Sub


Function FoundRanges(fRange As Range, fStr As String) As Range
Dim objFind As Range
Dim rFound As Range, FirstAddress As String

With fRange
Set objFind = .Find(what:=fStr, After:=fRange.Cells((fRange.Rows.Count), fRange.Columns.Count), _
LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=True)
If Not objFind Is Nothing Then
Set rFound = objFind
FirstAddress = objFind.Address
Do
Set objFind = .FindNext(objFind)
If Not objFind Is Nothing Then Set rFound = Union(objFind, rFound)
Loop While Not objFind Is Nothing And objFind.Address <> FirstAddress
End If
End With
Set FoundRanges = rFound
End Function

Function rList(aRange As Range) As Variant
Dim a() As Variant, rr As Range, c As Range, v As Variant
ReDim a(1 To aRange.Cells.Count)
Dim i As Integer

For Each rr In aRange.Areas
For Each c In rr
i = i + 1
a(i) = c.Value
Next c
Next rr

rList = a()
End Function

Public Function UniqueValues(theRange As Range) As Variant
Dim colUniques As New VBA.Collection
Dim vArr As Variant
Dim vCell As Variant
Dim vLcell As Variant
Dim oRng As Excel.Range
Dim i As Long
Dim vUnique As Variant
Set oRng = Intersect(theRange, theRange.Parent.UsedRange)
vArr = oRng
On Error Resume Next
For Each vCell In vArr
If vCell <> vLcell Then
If Len(CStr(vCell)) > 0 Then
colUniques.Add vCell, CStr(vCell)
End If
End If
vLcell = vCell
Next vCell
On Error GoTo 0

ReDim vUnique(1 To colUniques.Count)
For i = LBound(vUnique) To UBound(vUnique)
vUnique(i) = colUniques(i)
Next i

UniqueValues = vUnique
End Function

Sub StrToTXTFile(filePath As String, str As String)
Dim hFile As Integer
If Dir(GetFolderName(filePath), vbDirectory) = "" Then
MsgBox filePath, vbCritical, "Missing Folder"
Exit Sub
End If

hFile = FreeFile
Open filePath For Output As #hFile
If str <> "" Then Print #hFile, str
Close hFile
End Sub

Function GetFolderName(filespec As String) 'Returns path with trailing "\"
Dim fso As FileSystemObject, s As String
Set fso = New FileSystemObject
'Debug.Print fso.GetFile(filespec).path
s = fso.GetParentFolderName(filespec)
Set fso = Nothing
GetFolderName = s
End Function

[snb]

This might be sufficient.
Adapt the path to the destination folder.


Sub M_snb()
Set sd = CreateObject("scripting.dictionary")
Set fs = CreateObject("scripting.filesystemobject")

sn = Sheets("sheet1").Cells(1).CurrentRegion

For j = 2 To UBound(sn)
sd(sn(j, 4) & Format(sn(j, 2), " dd-mmm-yyyy")) = sd(sn(j, 4) & Format(sn(j, 2), " dd-mmm-yyyy")) & vbCrLf & sn(j, 1)
Next

For Each it In sd
fs.createtextfile("G:\OF\" & it & ".txt").write Mid(sd(it), 3)
Next
End Sub

[CCkfm2000]

Thanks Kenneth and snb,

both code works. :clap: