Merge & Extract Textfiles with Excel VBA

[acrolim]

Hello,

I have two text files with the following.

textfile:
001 Cholera
001.0 Cholera
001.1 Cholera
001.9 Cholera, unspecified

002 Typhoid
002.0 Typhoid fever
002.1 Typhoid A
002.2 Typhoid B
002.3 Typhoid
002.9 Typhoid , unspecified

And textfile 2:
00100 ANESTHESIA
00147 ANESTHESIA
00148 ANESTHESIA
00160 ANESTHESIA
00162 ANESTHESIA
00164 ANESTHESIA
00170 ANESTHESIA
00172 ANESTHESIA
00174 ANESTHESIA
00176 ANESTHESIA
00190 ANESTHESIA
00192 ANESTHESIA
00210 ANESTHESIA
00211 ANESTHESIA
00212 ANESTHESIA
00214 ANESTHESIA
00215 ANESTHESIA

I want to merge these two files and print them in one cell in my worksheet "Book1"
Preferebly I would like to extract the text that starts with "001" and ignore the rest.

The code I have is from the MS Blog and joins them but in a textfile, not in the excel file.

Sub AppendFiles1()

Dim SourceNum As Integer
Dim DestNum As Integer
Dim Temp As String

' If an error occurs, close the files and end the macro.
On Error GoTo ErrHandler

' Open the destination text file.
DestNum = FreeFile()
Open "C:\Users\SE-Anne\Desktop\textfile.txt" For Append As DestNum

' Open the source text file.
SourceNum = FreeFile()
Open "C:\Users\SE-Anne\Desktop\textfile2.txt" For Input As SourceNum

' Include the following line if the first line of the source
' file is a header row that you do now want to append to the
' destination file:
Line Input #SourceNum, Temp

' Read each line of the source file and append it to the
' destination file.
Do While Not EOF(SourceNum)
Line Input #SourceNum, Temp
Print #DestNum, Temp
Loop

CloseFiles:

' Close the destination file and the source file.
Close #DestNum
Close #SourceNum
Exit Sub

ErrHandler:
MsgBox "Error # " & Err & ": " & Error(Err)
Resume CloseFiles

End Sub

Please let me know the best way to this. Thanks!!

 

[netuser]

Is there any reason you want to do it with code ? why not just copy paste in Column A in excel ?

And in Column B you can put this to extract the one that start with 001

Excel 2010 32 bit
	A	B
1	Data	filter
2	001 ggg	001 ggg
3	2 ggg
4	3 ggg
5	4 ggg
6	001 ggg	001 ggg
Feuil1

Cell Formulas
Range	Formula
B2	=IF(LEFT(A2,3)="001",A2,"")
B3	=IF(LEFT(A3,3)="001",A3,"")
B4	=IF(LEFT(A4,3)="001",A4,"")
B5	=IF(LEFT(A5,3)="001",A5,"")
B6	=IF(LEFT(A6,3)="001",A6,"")

 

[acrolim]

I need to do this with code, because I will want to do other things with it that I can only do with code.

 

[acrolim]

And I would like to have the extracted text form the files in one cell
so, it would paste in cell A1:

0011 Cholera
...
001 Anesthesia
...

 

[netuser]

Depending on how long your text is, you wont be able to put all in 1 cell, there is a limit of number of characters

 

[acrolim]

It does not pass the limit, I tested it before.

 

[netuser]

I will try to come up with something but I am busy right now. Meanwhile someone else may help you

 

[acrolim]

Ok Thank you I appreciate it!

 

[netuser]

Got some free time and did this quickly ,

Sub importtxt()

Dim myFile As String, myFile2 As String, text As String, textline As String

myFile = "C:\Temp\textfile1.txt" ' Change to your text file path and name
myFile2 = "C:\Temp\textfile2.txt" ' Change to your text file path and name

Open myFile For Input As #1
Do Until EOF(1)
    Line Input #1, textline
    If Left(textline, 3) = "001" Then
    If text = "" Then
    text = textline
    Else
     text = text & vbCrLf & textline
     End If
     End If
Loop
Close #1

Range("A1").Value = text

text = ""


Open myFile2 For Input As #2
Do Until EOF(2)
    Line Input #2, textline
    If Left(textline, 3) = "001" Then
    If Range("A1").Value = "" Then
    text = textline
    Else
     text = text & vbCrLf & textline
     End If
     End If
Loop

Close #2

Range("A1").Value = Range("A1").Value & text


End Sub

 

[netuser]

There was a slight error in my code I corrected it above , let me know if it is good