import of txt list to Excel

[presto44]

Hello All,

Could anybidy help me with macros for importing txt list of th
following forward:

Company Name1
Address1
Tel1
Fax1
Email1

Company Name2
Address2
Tel2
Fax2
Email2
...........

Input to Excel file should be:
1. Company name1 - Address1 - Tel1 - Fax1 - Email1
2. Company name2 - Address2 - Tel2 - Fax2 - Email2
...........

Thank you for your assistant

 

[Bernie Deitrick]

presto,

Assuming you data starts in row 1, and each set is 6 rows down from the
previous:

Dim rows As Long
For rows = 1 To Range("A65536").End(xlUp).Row Step 6
Cells(rows, 1).Resize(6, 1).Copy
Range("B65536").End(xlUp)(2).PasteSpecial Transpose:=True
Next rows


HTH,
Bernie
MS Excel MVP

 

[Edward Ulle]

Try the following, note you need to include the Microsoft Scripting
Runtime to use FileSystemObject

Option Explicit

' Requires Tools->References Microsoft Scripting Runtime
Public Sub OpenFile()

Dim fsoFileSystemObject As FileSystemObject
Dim strFileName As String
Dim fFile As File
Dim tsTextStream As TextStream
Dim strLine As String
Dim wsNewWorkSheet As Worksheet
Dim lRow As Long

Set fsoFileSystemObject = CreateObject("Scripting.FileSystemObject")
strFileName = Application.GetOpenFilename

If strFileName = "False" Then
MsgBox "Cancelled"
Else
Set fFile = fsoFileSystemObject.GetFile(strFileName)
Set tsTextStream = fFile.OpenAsTextStream(ForReading)
Set wsNewWorkSheet =
Worksheets.Add(After:=Worksheets(Worksheets.Count))
With wsNewWorkSheet
.Name = "NewSheet"
.Range("A1") = "Company Name"
.Range("A1").Offset(0, 1) = "Address"
.Range("A1").Offset(0, 2) = "Telephone"
.Range("A1").Offset(0, 3) = "Fax"
.Range("A1").Offset(0, 4) = "E-mail"
End With

lRow = 0
Do While Not tsTextStream.AtEndOfStream
lRow = lRow + 1
' Read company name
strLine = tsTextStream.ReadLine
wsNewWorkSheet.Range("A1").Offset(lRow, 0) = strLine
' Read address
strLine = tsTextStream.ReadLine
wsNewWorkSheet.Range("A1").Offset(lRow, 1) = strLine
' Read phone number
strLine = tsTextStream.ReadLine
wsNewWorkSheet.Range("A1").Offset(lRow, 2) = strLine
' Read fax number
strLine = tsTextStream.ReadLine
wsNewWorkSheet.Range("A1").Offset(lRow, 3) = strLine
' Read email address
strLine = tsTextStream.ReadLine
wsNewWorkSheet.Range("A1").Offset(lRow, 4) = strLine
If Not tsTextStream.AtEndOfStream Then tsTextStream.SkipLine
Loop
tsTextStream.Close
End If

End Sub