VBA/Macro to create lists in notepad

[cgreene87]

Hi all,

I was wondering if the following query is even possible, I'm not certain.

I need to take the numbers on a spreadsheet in column A and generate a notepad file for each of the (price points column B) with the all corresponding numbers per price point saved into a notepad file (.txt) (one notepad file for all the numbers at 2.99, one notepad file for all the numbers at 3.99 etc). I've been copying and pasting these numbers into notepad but it is a laborious task and leaves room for error.

Many thanks if you are able to assist.

Best,

Craig

 

[lewisgmorris]

How about this...

You need to add the reference to the microsoft scriping runtime (in VBA editor go to TOOLS>> REFERENCES >> then add "Microsoft Scripting Runtime"

Make sure to add the correct sheetname (replace "Sheet1") and location (Replace "U:\")

Works well i think.

Sub savePricePointToTxtFile()



Dim fso As FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
Dim fsofolder As Folder
Dim filename As String
Dim c As String
Dim a As Range
Dim b As String


On Error GoTo err_error1
    
Set fsofolder = fso.GetFolder("U:\")
        
    For Each a In Worksheets("Sheet1").Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
    
        b = a.Offset(0, 1).Value & ".txt"
        
            If fso.FileExists(fsofolder.Path & b) Then
            
                fso.OpenTextFile(fsofolder.Path & b, 8).WriteLine (a.Value)
                
            Else
            
                fso.CreateTextFile fsofolder.Path & b
                fso.OpenTextFile(fsofolder.Path & b, 8).WriteLine (a.Value)
            
            End If
            
    Next a


Exit Sub


err_error1:
    
    MsgBox "There was a critical error", vbCritical


End Sub

 

[cgreene87]

Hi Lewis,

Many thanks for the above. However, when I go to add the Microsoft Scripting Runtime the reference box is grayed out (I am unable to select it), I will have to investigate to see why this is. In the meantime I devised the below script which is cumbersome but does the job as well. I just need to figure out how I can have the location for the text file be a generic one and not my desktop.

Sub to_new_tabs()


Const cl& = 2
Dim a As Variant, q As Variant, sh As Worksheet
Dim rws&, cls&, p&, i&, b As Boolean
Set sh = ActiveSheet
Application.ScreenUpdating = False
With Sheets.Add(after:=sh)
    sh.Cells(1).CurrentRegion.Copy .Cells(1)
    Set a = .Cells(1).CurrentRegion
    rws = a.Rows.Count
    cls = a.Columns.Count
    a.Sort a(1, cl), Header:=xlYes
    .Name = a(1, cl)
    a = a.Resize(rws)
    p = 1
    For i = p To rws
        If a(i, cl) <> a(p, cl) Then
            If b Then
                Sheets.Add.Name = a(p, cl)
                .Cells(p, 1).Resize(i - p, cls).Cut Cells(1, 1)
            End If
            b = True
            p = i
        End If
    Next i
End With
Application.ScreenUpdating = True


For Each sh In ThisWorkbook.Sheets
        sh.Range("B:B").ClearContents
    Next


    Dim ws As Worksheet


    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each ws In ThisWorkbook.Worksheets


    Sheets(ws.Name).Select
    Sheets(ws.Name).Copy
    ActiveWorkbook.SaveAs Filename:= _
    "C:\Users\Craig\Desktop\" & ws.Name & ".txt", _
    FileFormat:=xlText, CreateBackup:=False
    ActiveWorkbook.Close
    ThisWorkbook.Activate
    Next


End Sub

[/QUOTE]

 

[cgreene87]

Hello all,

I am having some trouble with my script. It works relatviely well but is not perfect. For some reason it cuts off my last line of data (in this case 179.99). Please see my list and script below. Many thanks for the support.

Item # 130144328 130296575 130144361 130280901 130280928 130297455 130297703 130439142 130476736 130416830 130472145 130475098 130511343 130148177 130280696 130146091 130146091 130146411 130146411 130144176 130507539 130148118 130148118 130146761 130146761 130144150 130252126 130184928 130184928 130145751 130145751 130280531 130280531 130155908 130155908 130297519 130184688 130473455 130476947 130507900 130507598 130507619 130472292 130507993 130434886 130184709 130144951 130290296 130297498 130413807 130151544 130508769 130240045 130479582 130478205 130473914 130508208 130476402 130472567 130511423 130507678 130473068 130476251 130473359 130511474 130508793 130438692 130437884 130508013 130414367 130414383 130441162 130471767 130508831 130472971 130508865 130476584 130476541 130507707 130473295 130473615 130476470 130508232 130511520 130477860 130476980 130473666 130145814 130155060 130155060 130318261 130151641 130147713 130316142 130414412 130415714 130438836 130146868 130150197 130150197 130318869 130318560 130318885 130146681 130155422 130147756 130413591 130410331 130149330 130150234 130162067 130476234 130507758 130507731 130239984 130315166 130316521 130475400 130162526 130162569 130293008 130162180 130507782 130507459 130317567 130149401 130144820 130146163 130151667 130416573 130413022 130437201 130440362 130147781 130155553 130147801 130150269 130149516 130150162 130149364 130436793 130318973 130318949 130318914 130315916 130474458 130293219 130144846 130149532 130415669 130299549 130293711 130146956 130145777 130416590 130412935 130437155 130437227 130155625 130471337 130410500 130317946 130435221 130471484 130471484 130471484 130316564 130440442 130413541 130218905 130218905 130218948 130184725 130299389 130472487 130251123 130151747 130144651 130410294 130291045 130293446 130281875 130281875 130438772 130439708 130471011 130294107 130291213 130439492 130291387 130440397 130318033 130434851 130478598 130297412 130292005 130438490 130251158 130148011 130148011 130151561 130434000 130475864 130156089 130280477 130316370 130434958 130433980 130440266 130438625 130414674 130434712 130434747 130156038 130156054 130144740 130144766 130437948 130146999 130146999 130438238 130415263 130144205 130145873 130476963 130413760 130437059 130151587 130151587 130410542 130475881 130473834 130434472 130476453 130477991 130437753 130414720 130319001 130471513 130434296 130434296 130441269 130438457 130508443 130509067 130439628 130144723 130147481 130155502 130155537 130155537 130147625 130145161 130145380 130473236 130473261 130440485 130476832 130438393 130439273 130474491 130414834 130318842 130318631 130318658 130318658 130318658 130436726 130511706 130241540 130251553 130440590 130438078 130471118 130147019 130144782 130144782 130472743 130438414 130437711 130472057 130240715 130251342 130251342 130413487 130289877 130434317 130510341 130438051 130410462 130437112 130441234 130317735 130438140 130145443 130144803 130144803 130145494 130184434 130184469 130439901 130148038 130438588 130296719 130293340 130410382 130417197 130413137 130415829 130414551 130472073 130472102 130414771 130414279 130437260 130318682 130251596 130240694 130315676 130434333 130434350 130289834 130439169 130414252 130437139 130410198 130185031 130184830 130184830 130148054 130148054 130281031 130417015 130417040 130297762 130297797 130417154 130416961 130241152 130416039 130510471 130411140 130472591 130415917 130242112 130436081 130250614 130510391 130240660 130250497 130410956 130410956 130410438 130417074 130417091 130290587 130413090 130148337 130148337 130148337 130148337 130148425 130148425 130148425 130148425 130145566 130145566 130147115 130297375 130315596 130315730 130315861 130476496 130476517 130434499 130148492 130148521 130148521 130155238 130252329 130252361 130435803 130251730 130435926 130410681 130410788 130435045 130292591 130410729 130410753 130410817 130507221 130474108 130435176 130435150 130251481 130475506 130290000 130290000 130510607 130476146 130472663 130474010 130435846 130511829 130476795 130250534 130251983 130412257 130471548 130471548 130507248 130241671 130241128 130282368 130282368 130251431 130413891 130434413 130507150 130162737 130439927 130315617 130439020 130315810 130316020 130316775 130155975 130145603 130155174 130439951 130439046 130316046 130437665 130155781 130155781 130145638 130145638 130416151 130240619 130414615 130410905 130410631 130292540 130241638 130435248 130241822 130240635 130240635 130511773 130475143 130436902 130473471 130473471 130241603 130282384 130242024 130241259 130472399 130471142 130294596 130510711 130282561 130282608 130282261 130474634 130474546 130435205 130471185 130283192 130282464 130410657 130435580 130282712 130474319 130510050 130510050 130510105 130282296 <tbody> </tbody>

Price 2.99 2.99 3.99 3.99 3.99 3.99 3.99 5.99 5.99 5.99 5.99 5.99 5.99 5.99 5.99 5.99 5.99 5.99 5.99 5.99 5.99 7.99 7.99 7.99 7.99 7.99 7.99 7.99 7.99 7.99 7.99 7.99 7.99 7.99 7.99 7.99 8.99 8.99 8.99 8.99 8.99 8.99 8.99 8.99 9.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 11.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 12.99 14.99 14.99 14.99 14.99 14.99 14.99 14.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 16.99 18.99 18.99 18.99 18.99 18.99 18.99 18.99 18.99 18.99 18.99 18.99 18.99 18.99 18.99 18.99 18.99 18.99 18.99 18.99 18.99 18.99 18.99 19.99 19.99 19.99 21.99 21.99 21.99 21.99 21.99 21.99 21.99 21.99 21.99 21.99 21.99 21.99 21.99 21.99 21.99 21.99 21.99 21.99 21.99 21.99 21.99 21.99 21.99 21.99 23.99 23.99 23.99 23.99 23.99 23.99 23.99 23.99 23.99 23.99 23.99 23.99 23.99 23.99 23.99 23.99 23.99 23.99 23.99 23.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 24.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 29.99 34.99 34.99 34.99 34.99 34.99 34.99 34.99 34.99 34.99 34.99 34.99 34.99 34.99 34.99 34.99 34.99 34.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 39.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 44.99 49.99 49.99 49.99 49.99 49.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 54.99 59.99 59.99 59.99 59.99 59.99 59.99 59.99 59.99 59.99 59.99 64.99 64.99 64.99 64.99 64.99 64.99 64.99 64.99 64.99 64.99 69.99 69.99 69.99 69.99 69.99 69.99 69.99 69.99 69.99 69.99 69.99 69.99 69.99 69.99 74.99 84.99 84.99 84.99 84.99 84.99 84.99 89.99 89.99 89.99 89.99 89.99 89.99 89.99 99.99 119.99 119.99 119.99 119.99 129.99 129.99 149.99 149.99 149.99 179.99 <tbody> </tbody>

<tbody>
</tbody>

Sub to_new_tabs()


Const cl& = 2
Dim a As Variant, q As Variant, sh As Worksheet
Dim rws&, cls&, p&, i&, b As Boolean
Set sh = ActiveSheet
Application.ScreenUpdating = False
With Sheets.Add(after:=sh)
sh.Cells(1).CurrentRegion.Copy .Cells(1)
Set a = .Cells(1).CurrentRegion
rws = a.Rows.Count
cls = a.Columns.Count
a.Sort a(1, cl), Header:=xlYes
.Name = a(1, cl)
a = a.Resize(rws)
p = 1
For i = p To rws
If a(i, cl) <> a(p, cl) Then
If b Then
Sheets.Add.Name = a(p, cl)
.Cells(p, 1).Resize(i - p, cls).Cut Cells(1, 1)
End If
b = True
p = i
End If
Next i
End With
Application.ScreenUpdating = True


For Each sh In ThisWorkbook.Sheets
sh.Range("B:B").EntireColumn.Delete
Next


Dim ws As Worksheet


Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets


Sheets(ws.Name).Select
Sheets(ws.Name).Copy
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\Craig\Desktop\PP Output" & ws.Name & ".txt", _
FileFormat:=xlText, CreateBackup:=False
ActiveWorkbook.Close
ThisWorkbook.Activate
Next


End Sub

 

[DocAElstein]

Hi Lewis,

Many thanks for the above. However, when I go to add the Microsoft Scripting Runtime the reference box is grayed out (I am unable to select it), I will have to investigate to see why this is. ........

Hi. I thought maybe instead of this

[COLOR=darkblue]Dim[/COLOR] fso [COLOR=darkblue]As[/COLOR] FileSystemObject
[COLOR=darkblue]Set[/COLOR] fso = CreateObject("Scripting.FileSystemObject")

you should have EITHER: This -

[COLOR=green]'--requires library reference to MS Scripting Runtime (called Early Binding)-[/COLOR]
[COLOR=green]'        Tools>>References>>scroll down and check the box next to Microsoft Scripting Runtime[/COLOR]
[COLOR=green]'  ..and then .....[/COLOR]
[COLOR=darkblue]Dim[/COLOR] fso [COLOR=darkblue]As[/COLOR] Scripting.FileSystemObject
[COLOR=darkblue]Set[/COLOR] fso = [COLOR=darkblue]New[/COLOR] Scripting.FileSystemObject

or this -

[COLOR=green]'    This Requires no reference.... (called Late Binding)[/COLOR]
[COLOR=green]'   ....[/COLOR]
[COLOR=darkblue]Dim[/COLOR] fso [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
[COLOR=darkblue]Set[/COLOR] fso = CreateObject("Scripting.FileSystemObject")

and always to be on the safe side have this at the end of your code:

[COLOR=darkblue]Set[/COLOR] fso = [COLOR=darkblue]Nothing[/COLOR]

AS for..

...... when I go to add the Microsoft Scripting Runtime the reference box is grayed out (I am unable to select it),
.....

That Usually means you are in F8 mode or doing something else in the Code window or spreadsheet so just make sure everyting is "dead"... for example not waiting for a carriage return etc.

 

[lewisgmorris]

Thanks for that, will come in handy.

 

[lewisgmorris]

Try this then.

Sub savePricePointToTxtFile()


Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim fsofolder As Object
Dim filename As String
Dim c As String
Dim a As Range
Dim b As String
On Error GoTo err_error1
Set fsofolder = fso.GetFolder("U:\")
        
    For Each a In Worksheets("Sheet1").Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        b = a.Offset(0, 1).Value & ".txt"
            If fso.FileExists(fsofolder.Path & b) Then
                fso.OpenTextFile(fsofolder.Path & b, 8).WriteLine (a.Value)
            Else
                fso.CreateTextFile fsofolder.Path & b
                fso.OpenTextFile(fsofolder.Path & b, 8).WriteLine (a.Value)
            End If
    Next a


Exit Sub


err_error1:
    MsgBox "There was a critical error", vbCritical
End Sub

 

[snb_]

Sub M_snb()
    ActiveSheet.Cells(1).CurrentRegion.resize(, 2).Copy
  
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
       .GetFromClipboard
       sn = Split(.GetText, vbCrLf)
    End With
    
    With CreateObject("scripting.filesystemobject")
      Do Until UBound(sn) = -1
        c00=split(sn(0),",")(1)
        .createtextfile("G:\OF\file" & c00 & ".csv").write = Join(Filter(sn, c00), vbCrLf)
        sn = Filter(sn, c00, False)
      Loop
    End With
End Sub

 

[DocAElstein]

Try this then.

Sub savePricePointToTxtFile()


Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim fsofolder As Object
Dim filename As String
Dim c As String
Dim a As Range
Dim b As String
On Error GoTo err_error1
Set fsofolder = fso.GetFolder("U:\")
        
    For Each a In Worksheets("Sheet1").Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        b = a.Offset(0, 1).Value & ".txt"
            If fso.FileExists(fsofolder.Path & b) Then
                fso.OpenTextFile(fsofolder.Path & b, 8).WriteLine (a.Value)
            Else
                fso.CreateTextFile fsofolder.Path & b
                fso.OpenTextFile(fsofolder.Path & b, 8).WriteLine (a.Value)
            End If
    Next a


Exit Sub


err_error1:
    MsgBox "There was a critical error", vbCritical
End Sub

Hi Lewis,
. I have not been fully following the Thread so I don't know exactly what the OP wants..

If he gives a screen shot of ( shortened maybe !) data showing clearly wot he has in the excel file and wot he wants the macro to do ... so how the text file should look like after running the macro..
……. Then I'll try and take another Look sometime:....

Alan


........

Hi cgreene.. For your info as regards giving us a "Picture” of wot is going on....

. There are various ways to do this. The first is preferred by this Forum for excel files as then everyone can see wot is going on quickly.. The Third method I prefer. - Then one can get on straight away with writing a code for you in the file you provide.

. 1 If you can, try uploading this, https://onedrive.live.com/?cid=8cffd...CE27E813%21189 instructions here MrExcel HTML Maker . This free Excel add-In is good for screen shots here of spreadsheets. Then everyone can quickly see what is going on and follow the Thread easily.
Or
. 2 Up left in the Thread editor is a table icon. Click that, create an appropriately sized table and fill it in. (To get this icon up in the Reply window you may need to click on the “Go Advanced” Button next to the Reply Button)
Or
. 3 Supply us with example Excel files (Can of course be shortened, or made - up data in case any info is sensitive) (and maybe a finished file as it should be (text .txt file in your case))
. For example send over this free thing: Box Net,
Remember to select Share after uploading and give us the link they provide.

 

[cgreene87]

Hi Doc, Lewis & Snb,

Many thanks for your assistance. The file and some examples of what the outputS should look like are linked and shared below additionally you will find a copy of my script qouted. The script is almost working currently except it cuts off the last price point (in this case 179.99). I basically need the numbers on the left to all be put into a text file under their corresponding price points (the right column).

Thanks again!

https://app.box.com/s/73sp1hye1rrhzyvra5a1

Sub to_new_tabs()

Const cl& = 2
Dim a As Variant, q As Variant, sh As Worksheet
Dim rws&, cls&, p&, i&, b As Boolean
Set sh = ActiveSheet
Application.ScreenUpdating = False
With Sheets.Add(after:=sh)
sh.Cells(1).CurrentRegion.Copy .Cells(1)
Set a = .Cells(1).CurrentRegion
rws = a.Rows.Count
cls = a.Columns.Count
a.Sort a(1, cl), Header:=xlYes
.Name = a(1, cl)
a = a.Resize(rws)
p = 1
For i = p To rws
If a(i, cl) <> a(p, cl) Then
If b Then
Sheets.Add.Name = a(p, cl)
.Cells(p, 1).Resize(i - p, cls).Cut Cells(1, 1)
End If
b = True
p = i
End If
Next i
End With
Application.ScreenUpdating = True


For Each sh In ThisWorkbook.Sheets
sh.Range("B:B").EntireColumn.Delete
Next


Dim ws As Worksheet


Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets


Sheets(ws.Name).Select
Sheets(ws.Name).Copy
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\Craig\Desktop\PP Output" & ws.Name & ".txt", _
FileFormat:=xlText, CreateBackup:=False
ActiveWorkbook.Close
ThisWorkbook.Activate
Next


End Sub