Format number as text on multiple files import to a Single Workbook

[avi]

Hello,
I want to Import Multiple Files to a Single Workbook and there is code
on http://excel.tips.net/Pages/T003148_Importing_Multiple_Files_to_a_Single_Workbook.html
that does the job with one exception:

I want all the imported data to be formated as text and not general (I
need leading zeros etc...).
What to add to that code & where ? TIA

 

[joel]

Instead of moving the workbook, add a new sheet and format as text the
copy and pastespecial as values. I change the open to use OPenText.
this should work

While x <= UBound(FilesToOpen)
With wkbAll
Set Newsht = .Sheets.Add(after:=.Sheets(Sheets.Count))
Newsht.Cells.NumberFormat = "@"

Workbooks.OpenText Filename:=FilesToOpen(x), _
DataType:=xlDelimited, _
Other:=True, OtherChar:=sDelimiter

Set wkbTemp = ActiveWorkbook
wkbTemp.Sheets(1).Cells.Copy
Newsht.Cells.PasteSpecial Paste:=xlPasteValues

End With
Wend

 

[Mike H]

Hi,

Not tested but add these 2 lines to the code

wkbTemp.Close (False)' Existing line
wkbAll.Worksheets(x).Cells.NumberFormat = "@" 'New line

and here

With wkbAll 'Existing line
.Worksheets(x).Cells.NumberFormat = "@" 'New line
--
Mike

When competing hypotheses are otherwise equal, adopt the hypothesis that
introduces the fewest assumptions while still sufficiently answering the
question.

 

[avi]

Well thanx Joel for your effort but

this should work

unfortunately it appears not to be working: "Subscript out of range"
error ; imports only last file selected not all of them; does not
format number as text: I have lost my leading zeros and cell
properties reads "General" (on 1 imported file).

 

[avi]

Well thanx Mike for your effort but
unfortunately it appears not to be working:
"Subscript out of range" error ; does not import all the selected
files into one workbook but only 2 of the selected & into 2 workbooks
one of which has cells format as text but still I have lost my leading
zeros.

 

[joel]

I fixed the code so it doesn't open the text file twice which wa
giving the error. If the code is still dropping the leading zeroes the
check if the text file when open in excel is also missing the zero, o
the problem is in copying the sheet between the 2 workbooks.


Sub CombineTextFiles()
Dim FilesToOpen
Dim x As Integer
Dim wkbAll As Workbook
Dim wkbTemp As Workbook
Dim sDelimiter As String

On Error GoTo ErrHandler
Application.ScreenUpdating = False

sDelimiter = "|"

FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Text Files (*.txt), *.txt", _
MultiSelect:=True, Title:="Text Files to Open")

If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If

x = 1

While x <= UBound(FilesToOpen)
With wkbAll
Set Newsht = .Sheets.Add(after:=.Sheets(Sheets.Count))
Newsht.Cells.NumberFormat = "@"

Workbooks.OpenText Filename:=FilesToOpen(x), _
DataType:=xlDelimited, _
Other:=True, OtherChar:=sDelimiter

Set wkbTemp = ActiveWorkbook
wkbTemp.Sheets(1).Cells.Copy
Newsht.Cells.PasteSpecial Paste:=xlPasteValues
wkbTemp.close savechanges:=false

End With
Wend

ExitHandler:
Application.ScreenUpdating = True
Set wkbAll = Nothing
Set wkbTemp = Nothing
Exit Sub

ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub

 

[avi]

Joel,

When running your last code there is error: "Object variable with
Block variable not set." and code is interrupted, nothing happens.

 

[avi]

after a while, here's the modified solution code:
----------

'http://excel.tips.net/Pages/
T003148_Importing_Multiple_Files_to_a_Single_Workbook.html

Sub CombineTextFiles()
Dim FilesToOpen
Dim x As Integer
Dim wkbAll As Workbook
Dim wkbTemp As Workbook
Dim sDelimiter As String

On Error GoTo ErrHandler
Application.ScreenUpdating = False

sDelimiter = "|"

FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Text Files (*.txt), *.txt", _
MultiSelect:=True, Title:="Text Files to Open")

If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If

x = 1
' Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x)) *** below is
forced text format

Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x),
Format:=xlTextFormat)


wkbTemp.Sheets(1).Copy
Set wkbAll = ActiveWorkbook
wkbTemp.Close (False)
wkbAll.Worksheets(x).Columns("A:A").TextToColumns , _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:= _
xlNone, ConsecutiveDelimiter:=False, Tab:=True,
Semicolon:=False, Comma _
:=False, Space:=False, Other:=False, OtherChar:="|", _
FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 2),
Array(5, 2), Array(6, 2), Array(7, 2), Array(8, 2), Array(9, 2),
Array(10, 2), Array(11, 2), Array(12, 2), Array(13, 2), Array(14, 2),
Array(15, 2), Array(16, 2), Array(17, 2), Array(18, 2), Array(19, 2),
Array(20, 2), Array(21, 2), Array(22, 2), Array(23, 2), Array(24, 2),
Array(25, 2), Array(26, 2), Array(27, 2), Array(28, 2), Array(29, 2),
Array(30, 2), Array(31, 1), Array(32, 1), Array(33, 1), Array(34, 1),
Array(35, 1), Array(36, 1), Array(37, 1), Array(38, 1), Array(39, 1),
Array(40, 1), Array(41, 9))

' **** array forcing text format (2)



x = x + 1

While x <= UBound(FilesToOpen)
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
With wkbAll
wkbTemp.Sheets(1).Move After:=.Sheets(.Sheets.Count)
wkbAll.Worksheets(x).Columns("A:A").TextToColumns , _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:= _
xlNone, ConsecutiveDelimiter:=False, Tab:=True,
Semicolon:=False, Comma _
:=False, Space:=False, Other:=False, OtherChar:="|", _
FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 2),
Array(5, 2), Array(6, 2), Array(7, 2), Array(8, 2), Array(9, 2),
Array(10, 2), Array(11, 2), Array(12, 2), Array(13, 2), Array(14, 2),
Array(15, 2), Array(16, 2), Array(17, 2), Array(18, 2), Array(19, 2),
Array(20, 2), Array(21, 2), Array(22, 2), Array(23, 2), Array(24, 2),
Array(25, 2), Array(26, 2), Array(27, 2), Array(28, 2), Array(29, 2),
Array(30, 2), Array(31, 1), Array(32, 1), Array(33, 1), Array(34, 1),
Array(35, 1), Array(36, 1), Array(37, 1), Array(38, 1), Array(39, 1),
Array(40, 1), Array(41, 9))

' **** array forcing text format (2) although seems not
necessary


End With
x = x + 1
Wend

ExitHandler:
Application.ScreenUpdating = True
Set wkbAll = Nothing
Set wkbTemp = Nothing
Exit Sub

ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
----------------------------------------------------