I am reusing code Import Multiple text files into workbook where worksheet name matches text file name
This code is creating multiple worksheets and importing pipe delimited data into individual columns.
I need all the cells to be set to Text qualified before it does the text to columns.
Basically I want all the columns to be in text format instead of default General as the 16 digit numbers that I have in my file are getting messed up with General format.
I did try to put below lines but it changes the format after text to column is completed.
cells.select
Selection.NumberFormat = "#"
Here is the code that I am using
Sub Extract()
Dim FilesToOpen
Dim x As Integer
Dim wkbAll 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
Set wkbAll = Application.ActiveWorkbook
x = 1
With Workbooks.Open(Filename:=FilesToOpen(x))
.Worksheets(1).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
Other:=True, OtherChar:="|"
.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
.Close False
End With
x = x + 1
While x <= UBound(FilesToOpen)
With Workbooks.Open(Filename:=FilesToOpen(x))
.Worksheets(1).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:=sDelimiter
.Sheets(1).Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End With
x = x + 1
Wend
wkbAll.Save
ExitHandler:
Application.ScreenUpdating = True
Set wkbAll = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
Try this (I haven't). It (hopefully) sets all cells in the sheet to text. With see commented section for the addition.
Sub Extract()
Dim FilesToOpen
Dim x As Integer
Dim wkbAll 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
Set wkbAll = Application.ActiveWorkbook
x = 1
With Workbooks.Open(Filename:=FilesToOpen(x))
' ---------------------------------------------------
.Worksheets(1).Cells.NumberFormat = "#"
' ---------------------------------------------------
.Worksheets(1).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
Other:=True, OtherChar:="|"
.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
.Close False
End With
x = x + 1
While x <= UBound(FilesToOpen)
With Workbooks.Open(Filename:=FilesToOpen(x))
.Worksheets(1).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:=sDelimiter
.Sheets(1).Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End With
x = x + 1
Wend
wkbAll.Save
ExitHandler:
Application.ScreenUpdating = True
Set wkbAll = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
Not the permanent solution but I added below change which looks like resolved my problem. Since the longest record in one of my file has 45 cells I auto recorded below Macro and appended to my code after OtherChar:="|" and now it is working as I wanted.
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, 2), _
Array(32, 2), Array(33, 2), Array(34, 2), Array(35, 2), Array(36, 2), Array(37, 2), Array( _
38, 2), Array(39, 2), Array(40, 2), Array(41, 2), Array(42, 2), Array(43, 2), Array(44, 2), _
Array(45, 2)), TrailingMinusNumbers:=True
Related
I use a simple macro, insert a "txt" file and then split it into columns
Sub POR_Import()
Dim ws As Worksheet, strFile As String
Call Smaz_vstup_POR
Set ws = ActiveWorkbook.Sheets("POR_IMPORT") 'set to current worksheet name
strFile = Application.GetOpenFilename("Text Files (*.*),*.*", , "Please select text file...")
With ws.QueryTables.Add(Connection:="TEXT;" & strFile, Destination:=ws.Range("A1"))
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.Refresh
Call SplitPOR
i = MsgBox("Done", vbOKOnly + vbInformation)
End With
End Sub
and split
Sub SplitPOR()
Sheets("POR_IMPORT").Select
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("POR_divide").Select
Columns("A:A").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, 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, 2), _
Array(32, 2), Array(33, 2), Array(34, 2), Array(35, 2), Array(36, 2), Array(37, 2), Array( _
38, 2), Array(39, 2), Array(40, 2), Array(41, 1), Array(42, 2), Array(43, 2), Array(44, 2), _
Array(45, 2), Array(46, 2), Array(47, 2), Array(48, 2), Array(49, 2), Array(50, 2), Array( _
51, 2), Array(52, 2), Array(53, 2), Array(54, 2), Array(55, 2), Array(56, 2), Array(57, 2), _
Array(58, 2), Array(59, 2), Array(60, 2), Array(61, 2), Array(62, 2), Array(63, 2)), _
TrailingMinusNumbers:=True
End Sub
But every time I want to repeat the process I have to close and reopen excel. The moment you insert the txt for the second time excel will automatically split it according to how it was split the first time.
Is there please any possible treatment for this case?
Apologize once more for being obtuse and not understanding what you meant!
Please, try using the next optimized solution:
Sub POR_Import()
Dim ws As Worksheet, strFile As String
Call Smaz_vstup_POR
Set ws = ActiveWorkbook.Sheets("POR_IMPORT") 'set to current worksheet name
ws.UsedRange.ClearContents 'clear the previous used range content
'Normalize the TextToColumns behavior:____________________________________________________________
With ws.Range("A1")
.value = "1,2,3"
.TextToColumns Destination:=ws.Range("A1"), DataType:=xlDelimited, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, space:=False, Other:=False, FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
.ClearContents
End With
'____________________________________________________________________________________________
strFile = Application.GetOpenFilename("Text Files (*.*),*.*", , "Please select text file...")
With ws.QueryTables.Add(Connection:="TEXT;" & strFile, Destination:=ws.Range("A1"))
.TextFileParseType = xlDelimited
.TextFileTabDelimiter = True
.Refresh
End With
ws.QueryTables(ws.QueryTables.count).Delete 'delete the query after bringing the necessary text
SplitPOR ws 'call the splitting function with ws sheet as argument
MsgBox "Done", vbOKOnly + vbInformation
End Sub
Sub SplitPOR(ws As Worksheet)
Dim wsP_d As Worksheet, arrtxt(62), i As Long
Set wsP_d = Worksheets("POR_divide")
wsP_d.UsedRange.ClearContents 'clear the content, to not be ask about overwriting
wsP_d.Range("A:A").value = ws.Columns("B:B").value 'copy the column without using clipboard
For i = 0 To UBound(arrtxt) 'create the array to be passed to FieldInfo TextToColumns parameter
arrtxt(i) = Array(i + 1, 2)
Next i
'Use a more compact way:
wsP_d.Range("A:A").TextToColumns Destination:=wsP_d.Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, space:=False, Other:=True, OtherChar _
:="¦", FieldInfo:=arrtxt, TrailingMinusNumbers:=True
End Sub
Please, send some feedback after testing it. I will feel better knowing that I could help, after my stupid approach in comments, not being able to understand how what you were saying was possible...
I'd like to keep a cell with blank when there is no data.
Keep a cell with blank
I like to keep C3 as Empty cell like this Sample.
But My VBA gave me Sample.
Can anyone help me?
My code is:
FileToOpen = Application.GetOpenFilename(FileFilter:="Text Files(*.txt),*txt", MultiSelect:=True)
If IsArray(FileToOpen) Then
Application.ScreenUpdating = False
For i = 1 To UBound(FileToOpen)
Workbooks.OpenText _
Filename:=FileToOpen(i), _
StartRow:=1, _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, _
Tab:=True, _
Comma:=True, _
FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 1), _
Array(5, 2), Array(6, 2), Array(7, 2), Array(8, 2), Array(9, 2))
Set wbTextImport = ActiveWorkbook
wbTextImport.Worksheets(1).Range("A1").CurrentRegion.Copy
wsMaster.Activate
Range("A" & tgRow).Select
ActiveSheet.Paste
Application.CutCopyMode = False
wbTextImport.Close False
wsMaster.Rows(tgRow).Delete Shift:=xlUp
tgRow = wsMaster.Cells(wsMaster.Rows.Count, 1).End(xlUp).Row + 1
Next i
My Excel VBA script pulls data from other files, and my script isn't very good. How can I speed the file up?
So I pull 11x2737 data from each of 8 text files and pull 3x70101 from each of another 8 text files. It takes over 2 minutes to do this.
Set conFolder = CreateObject("Scripting.FileSystemObject")
For Each conFile In conFolder.GetFolder(folderName).Files
If InStr(conFile, "con.dat") > 0 Then
Set WorkB4 = Workbooks.Open(Filename:=conFile)
WorkB4.Activate
WorkB4.Application.DisplayAlerts = False
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1)), _
TrailingMinusNumbers:=True
Cells.Select
Selection.Copy
conBottle = Left(Right(conFile, 9), 1)
WorkB1.Activate
Sheets("Bot" & conBottle).Select
Range("A1").Select
ActiveSheet.Paste
WorkB4.Application.DisplayAlerts = True
WorkB4.Application.CutCopyMode = False
WorkB4.Close SaveChanges:=False
End If
Next
I'm hoping there's a way to pull this data as fast as possible (ideally within 5 seconds).
Avoiding Select and Activate, turning off ScreenUpdating, and skipping the clipboard should help, but typically the biggest bottleneck would be network or disk I/O: if the text files are on a network share, try copying them locally first.
So I refactored the code a bit, and there's only WorkB1 I couldn't work out where it came from.
None of this is tested, but it should give you a workable starting point.
Option Explicit
Public Sub ProcessFiles(ByVal Path As String)
Dim WorkB1 As Workbook ' <~
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
On Error GoTo CleanFail
With CreateObject("Scripting.FileSystemObject")
Dim conFolder As Object
Set conFolder = .GetFolder(Path)
Dim conFile As Variant '/String
For Each conFile In conFolder.Files
If InStr(conFile, "con.dat", VbCompareMethod.vbTextCompare) > 0 Then
ProcessFile conFile, WorkB1
End If
Next
End With
CleanExit:
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Application.Calculation = xlCalculationAutomatic
Exit Sub
CleanFail:
Debug.Print Err.Description
Resume CleanExit
End Sub
Private Sub ProcessFile(ByVal conFile As String, ByVal WorkB1 As Workbook)
On Error GoTo CleanFail
Dim book As Workbook
Set book = Workbooks.Open(conFile)
Dim sheet As Worksheet
Set sheet = book.Worksheets(1)
Dim dataRange As Range
Set dataRange = sheet.Columns(1)
Const NumberOfColumns As Long = 11
dataRange.TextToColumns _
destination:=sheet.Range("A1"), _
DataType:=xlDelimited, _
TextQualifier:=xlTextQualifierDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, _
Semicolon:=False, _
Comma:=True, _
Space:=False, _
Other:=False, _
FieldInfo:=Array( _
Array(1, 1), _
Array(2, 1), _
Array(3, 1), _
Array(4, 1), _
Array(5, 1), _
Array(6, 1), _
Array(7, 1), _
Array(8, 1), _
Array(9, 1), _
Array(10, 1), _
Array(11, 1)), _
TrailingMinusNumbers:=True
Dim dataRows As Long
dataRows = sheet.Range("A" & sheet.Rows.Count).End(xlUp).Row
Dim sourceRange As Range
Set sourceRange = sheet.Range("A1", sheet.Cells(dataRows, NumberOfColumns))
Debug.Print "Source: " & sourceRange.Address(External:=True)
Dim conBotName As String
conBotName = Left$(Right$(conFile, 9), 1)
Dim conBotSheet As Worksheet
Set conBotSheet = WorkB1.Worksheets("Bot" & conBotName)
Dim destination As Range
Set destination = conBotSheet.Range("A1", conBotSheet.Cells(dataRows, NumberOfColumns))
Debug.Print "Destination: " & destination.Address(External:=True)
destination.Value = sourceRange.Value
book.Close SaveChanges:=False
CleanExit:
Exit Sub
CleanFail:
Debug.Print Err.Description
Resume CleanExit
End Sub
I want to paste the columns of this text file in my workbook.
USAF-WBAN_ID STATION NAME COUNTRY STATE LATITUDE LONGITUDE ELEVATION
------------ ------------------------------ -------------------------------------------------- ------------------------------ -------- --------- ---------
404200 99999 AL AHSA SAUDI ARABIA +25.285 +049.485 +0179.2
I want to pull 7 variables (7 columns)
USAF-WBAN_ID; STATION NAME; COUNTRY; STATE; LATITUDE; LONGITUDE; ELEVATION
Below is what I've tried in several variations, and results are not reliable.
Sub A1_StationID()
Dim vFile As Variant
Dim wbCopyTo As Workbook
Dim wsCopyTo As Worksheet
Dim wbCopyFrom As Workbook
Dim wsCopyFrom As Worksheet
Set wbCopyTo = ActiveWorkbook
Set wsCopyTo = ActiveSheet
MsgBox "Please select weather stn.txt document"
Dim vFileName
vFileName = Application.GetOpenFilename("Text Files (*.txt), *.txt")
Application.ScreenUpdating = False
Workbooks.OpenText Filename:=vFileName, _
Origin:=xlMSDOS, StartRow:=1, DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(13, 1), Array(44, 1), _
Array(127, 1), Array(136, 1), Array(147, 1), Array(154, 1)), _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, _
Other:=False, TrailingMinusNumbers:=True
Set wbCopyFrom = Workbooks.Open(vFileName)
End Sub
Some of the output I get:
If I add a breakpoint on the second to last line of code, I get closer to the output I desire (with messed up columns).
First off - fantastic job posting working code and usable example data.
You were missing the array/field info designation for state and your final 3 columns were ~1/2 characters off. I removed the delimiter options as they don't matter if you're using xlFixedWidth.
Change
Workbooks.OpenText Filename:=vFileName, _
Origin:=xlMSDOS, StartRow:=1, DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(13, 1), Array(44, 1), _
Array(127, 1), Array(136, 1), Array(147, 1), Array(154, 1)), _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, _
Other:=False, TrailingMinusNumbers:=True
to
Workbooks.OpenText Filename:=vFileName, _
Origin:=xlMSDOS, StartRow:=1, DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(13, 1), Array(44, 1), _
Array(95, 1), Array(126, 1), Array(135, 1), Array(144, 1), Array(154, 1)), _
TextQualifier:=xlDoubleQuote, TrailingMinusNumbers:=True
As a side-note Excel has a bad tendency to remember Text to Columns settings so if you were messing with those earlier, make sure they are set to standard settings.
Conside this Excel VBA macro:
Option Compare Text
Public Sub ColumnATextToColumns()
Dim rng As range
Set rng = Columns("A:A")
Dim nrColumns As Integer
nrColumns = CountCharacter(Cells(1, 1), "|") + 1
Dim FieldInfoVal As Variant
ReDim FieldInfoVal(1 To nrColumns)
For i = 1 To nrColumns
FieldInfoVal(i) = "Array(" & i & ", 2)"
Next i
rng.TextToColumns Destination:=range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="|", FieldInfo:=FieldInfoVal, _
TrailingMinusNumbers:=True
End Sub
Public Function CountCharacter(ByVal value As String, ByVal ch As String) As Integer
Dim char As String
Dim cnt As Integer
cnt = 0
For i = 1 To Len(value)
char = Mid(value, i, 1)
If char = ch Then cnt = cnt + 1
Next i
CountCharacter = cnt
End Function
It compiles and runs but nothing happens.
The macro without dynamic creation of the FieldInfo value does work:
Columns("A:A").Select
Selection.TextToColumns Destination:=range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, 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)), TrailingMinusNumbers:= _
True