Extract Text File data to worksheet - excel

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.

Related

Edit this code that it can open ANY .dcm file and not the specific one i selected

I want to open .dcm files and edit them. Then the .dcm is read and placed before the active sheet i have on my current workbook. But i need to open any .dcm file, not only one specific one.
This is my current code
Sub Makro2()
'
' Makro2 Makro
'
'
Workbooks.OpenText Filename:= _
"H:\ENA\N_EN_AD3\3000_Mitarbeiter\Babacan\von_Nils\C7BB2HD3IINA_NRM_X302.dcm", _
Origin:=28592, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=True, _
Comma:=True, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), _
Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1)), TrailingMinusNumbers:=True
Range("A1").Select
Sheets("C7BB2HD3IINA_NRM_X302").Select
Sheets("C7BB2HD3IINA_NRM_X302").Move Before:=Workbooks( _
"ChrSet_Applikationsumgebung_inklHiAlti_X248_20221130.xlsm").Sheets(8)
End Sub
Usual method is to use a dialog box.
Option Explicit
Sub Makro2()
Const FOLDER = "H:\ENA\N_EN_AD3\3000_Mitarbeiter\Babacan\von_Nils\" ' initial search
' select file
Dim filename As String
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = FOLDER
.Title = "Please select the file to read"
.Filters.Add "DCM File", "*.dcm", 1
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then 'If no file is selected, abort
MsgBox "You did not select a file", vbExclamation
Exit Sub
End If
filename = .SelectedItems(1)
End With
' open selected workbook
Workbooks.OpenText filename:=filename, _
Origin:=28592, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=True, _
Comma:=True, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), _
Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1)), TrailingMinusNumbers:=True
With ActiveWorkbook
.Sheets(1).Move Before:=ThisWorkbook.Sheets(8)
End With
MsgBox "Done"
End Sub

How to format as Text using Text-To-Columns

This code works using text to columns to separate column A into as many columns as I need, but I cannot figure out a way to make it do this with all columns outputted into text format.
Sub TxT_to_Columns()
ActiveWorkbook.ActiveSheet.Range("A:A").TextToColumns _
Destination:=Range("A1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
Other:=True, _
OtherChar:="|"
End Sub
How can I do the same thing but output all columns to text format?
Thank you,
You use FieldInfo:
FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2)),
FieldInfo uses an array of arrays: Array(Array(Column,Type),...)
You can get the types from here:
https://learn.microsoft.com/en-us/office/vba/api/excel.xlcolumndatatype
If you know you want to do all the columns then you can pre fill an variant arr variable:
Sub TxT_to_Columns()
Dim arr(1 To 10) As Variant
arr(1) = Array(1, 2)
arr(2) = Array(2, 2)
arr(3) = Array(3, 2)
arr(4) = Array(4, 2)
arr(5) = Array(5, 2)
arr(6) = Array(6, 2)
arr(7) = Array(7, 2)
arr(8) = Array(8, 2)
arr(9) = Array(9, 2)
arr(10) = Array(10, 2)
ActiveWorkbook.ActiveSheet.Range("A:A").TextToColumns _
Destination:=ActiveWorkbook.ActiveSheet.Range("A1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=True, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
Other:=True, _
OtherChar:="|", _
FieldInfo:=arr
End Sub
Firstly, all the credit must go to Scott Craner!
I will only show a shorter way of arrays building, as response at what #Sabatino Ognibene asked lately. I am sure that Scott knew that, but he wanted to present the array building in a way able to easily be understood.
Dim arr() As Variant, i As Long, nrCol As Long
nrCol = 12 'the number of columns you need to result
ReDim arr(1 To nrCol) As Variant
For i = 1 To nrCol
arr(i) = Array(i, 2) '2 will be used for `Text` formatting.
Next

Automate report making VBA

I'm trying to automate a report making, i have to copy/paste data from .txt files that are in the same carpet, to do so i use a window because using the path is inefficient when using in other computers. Errors i encounter:
I want the data type of all the cells to be text so i can transform
the date into dd/mm/yyyy
It only modifies some files and some not.
I've tried tons of macros i've made but i can't fix the errors.
Sub REP_DET_Report()
myBook = ActiveWorkbook.Name
Set nav = CreateObject("shell.application")
folder = nav.browseforfolder(0, "PICK FOLDER", 0, "c:\").items.Item.Path
ChDir folder & "\"
file = Dir("*.txt")
Do While file <> ""
Workbooks.OpenText file, origin:=xlWindows, startrow:=1, DataType:=xlDelimited
Dim objRange1 As Range
'Set up the ranges
Set objRange1 = Range("A1:A1048576")
'Do the first parse
objRange1.TextToColumns _
Destination:=Range("A1"), _
FieldInfo:=Array(Array(1, xlTextFormat), Array(2, xlTextFormat), Array(3, xlTextFormat), Array(4, xlTextFormat), Array(5, xlTextFormat), Array(6, xlTextFormat), Array(7, xlTextFormat), Array(8, xlTextFormat), Array(9, xlTextFormat), Array(10, xlTextFormat)), _
DataType:=xlDelimited, _
Tab:=False, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
other:=True, _
OtherChar:="|"
other = ActiveWorkbook.Name
ActiveSheet.Copy before:=Workbooks(myBook).Sheets(1)
Workbooks(other).Close False
file = Dir()
Loop
End Sub

AddChart in a sheet that is not active/selected (VBA Excel) [duplicate]

This question already has answers here:
Excel VBA, getting range from an inactive sheet
(3 answers)
Closed 3 years ago.
I'm trying to create a new chart with the following code:
Sheet1.Range("C1:C21").TextToColumns Destination:=Sheet1.Range("C1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Sheet1.Select
Set classificacio = Sheet1.Shapes.AddChart2(Style:=-1, XlChartType:=xlBarStacked, Left:=Sheet1.Cells(1, 1).Left, Top:=Sheet1.Cells(1, 1).Top, Width:=Sheet1.Range(Cells(1, 1), Cells(15, 8)).Width, Height:=Sheet1.Range(Cells(1, 1), Cells(20, 8)).Height, NewLayout:=True).Chart
classificacio.SetSourceData Source:=Range(Sheet1.Cells(11, 2), Sheet1.Cells(20, 3))
classificacio.HasTitle = False
It works. However, it doesn't work when I delete Sheet1.Select because the code starts when Sheet3 is active. It seems that Set classificacio = Sheet1.Shapes... only makes sense when Sheet1 is the ActiveSheet.
How could I create this chart avoiding the selection of Sheet1, where the chart is created, and keeping always Sheet3 as the ActiveSheet?
You are getting that error because the Cells object are not fully qualified. If you do not qualify them, then they will refer to the active sheet.
Change Sheet1.Range(Cells(1, 1), Cells(15, 8)) to Sheet1.Range(Sheet1.Cells(1, 1), Sheet1.Cells(15, 8)). Same with Sheet1.Range(Cells(1, 1), Cells(20, 8))
Or better still, Put then in a With-End With Block (Untested).
With Sheet1
.Range("C1:C21").TextToColumns Destination:=.Range("C1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Set classificacio = .Shapes.AddChart2(Style:=-1, XlChartType:=xlBarStacked, _
Left:=.Cells(1, 1).Left, _
Top:=.Cells(1, 1).Top, _
Width:=.Range(.Cells(1, 1), .Cells(15, 8)).Width, _
Height:=.Range(.Cells(1, 1), .Cells(20, 8)).Height, _
NewLayout:=True).Chart
classificacio.SetSourceData Source:=Range(.Cells(11, 2), .Cells(20, 3))
classificacio.HasTitle = False
End With

Convert numbers in imported txt file data to text format

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

Resources