Export from Excel to text file with a twist

[FRED]

I'm new to VB and would really appreciate any help.
What I'm trying to do is export with out any prompts or just to be
prompted once for the locations were to save the new text files. If
that's not possible create the text files in the same directory as the
excel file
What I'm trying to do is export column B to a text file and uses the
name in column A as the text file name.
Column A has over a 150 different site codes and B will always have
text (example below).
Here is an example of my sheet:

A B
Site Context
HPW smithc,ou=users,ou=wwmg,ou=hpw,ou=na,o=tmt
PLB jonesh,ou=users,ou=pgr,ou=plb,ou=na,o=tmt
LVL thomass,ou=users,ou=pgr,ou=lvl,ou=na,o=tmt
LVL johno,ou=users,ou=pgr,ou=lvl,ou=na,o=tmt
HPW lbersoni,ou=users,ou=wwmg,ou=hpw,ou=na,o=tmt
PLB masonp,ou=users,ou=pgr,ou=plb,ou=na,o=tmt

What I'm trying to get is

HPW.txt and inside
smithc,ou=users,ou=wwmg,ou=hpw,ou=na,o=tmt
bersoni,ou=users,ou=wwmg,ou=hpw,ou=na,o=tmt

LVL.txt
thomass,ou=users,ou=pgr,ou=lvl,ou=na,o=tmt
johno,ou=users,ou=pgr,ou=lvl,ou=na,o=tmt

And so on.

I have learned how to extract data manually from this group, but I
would love to be able to do it automatically. Any help would be
greatly appreciated.

 

[equiangular]

Hi,

You may give it a try

Sub test()

Dim r As Range
Dim arr As Variant
Dim cnt As Long
Dim n As Long
Dim filenumber As Long
Dim s As String

Set r = Range("A1").CurrentRegion

r.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlStroke, DataOption1:=xlSortNormal

arr = r.Value

Set r = Nothing

cnt = 2
n = UBound(arr, 1)
Do While cnt <= n
s = arr(cnt, 1)

filenumber = FreeFile
Open s & ".txt" For Output As #filenumber

Do
Print #filenumber, arr(cnt, 2)
cnt = cnt + 1
If cnt > n Then Exit Do
Loop While s = arr(cnt, 1)

Close #filenumber
Loop

End Sub

 

[FRED]

Thanks for the great code equiangular.

That worked perfect, but is there a way to prompt once for the
locations to save the new text files or create the text files in the
same directory as the
original excel file.

 

[equiangular]

Sub test()

Dim r As Range
Dim arr As Variant
Dim cnt As Long
Dim n As Long
Dim filenumber As Long
Dim s As String, sPath As String

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Save file in folder..."
.InitialFileName = ActiveWorkbook.Path & "\"
If .Show Then ' User click OK
sPath = .SelectedItems(1)
Else ' Use current dir
sPath = ""
End If
Debug.Print sPath
End With

Set r = Range("A1").CurrentRegion

r.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlStroke, DataOption1:=xlSortNormal

arr = r.Value

Set r = Nothing

cnt = 2
n = UBound(arr, 1)
Do While cnt <= n
s = arr(cnt, 1)

filenumber = FreeFile
Open sPath & s & ".txt" For Output As #filenumber

Do
Print #filenumber, arr(cnt, 2)
cnt = cnt + 1
If cnt > n Then Exit Do
Loop While s = arr(cnt, 1)

Close #filenumber
Loop

End Sub

 

[FRED]

That worked perfect.

Thank You