Related
I have this code that pastes entire txt file contents to my active workbook but it loses leading "0" in cells:
Dim FileToOpen As Variant
Dim OpenBook As Workbook
FileToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If FileToOpen <> False Then
Set OpenBook = Application.Workbooks.Open(FileToOpen)
OpenBook.Sheets(1).UsedRange.Select
Selection.NumberFormat = "#"
OpenBook.Sheets(1).UsedRange.Copy
ThisWorkbook.Worksheets("BOM").Range("C1").PasteSpecial xlPasteValues
OpenBook.Close False
End If
I tried to work around it by adding
OpenBook.Sheets(1).UsedRange.Select
Selection.NumberFormat = "#"
But it doesn't do the trick.
So how do I paste the contents and not lose leading "0"?
To do what you want, you cannot OPEN the file. You must IMPORT the file. That way you can designate the data as being text before Excel turns it into a numeric value. Once Excel turns it into a number, formatting alone will not recover the original textual value
eg, to import the file, use the Workbooks.OpenText method:
Application.Workbooks.OpenText _
Filename:=FileToOpen, _
DataType:=xlDelimited, _
comma:=True, Tab:=False, semicolon:=False, Space:=False, other:=False, _
fieldinfo:=Array(Array(1, xlTextFormat), Array(2, xlTextFormat))
Then you can do a simple copy/paste operation and the text property should be maintained.
eg:
ActiveSheet.UsedRange.Copy Destination:= 'your fully qualified destination
Putting it all together, something like:
Option Explicit
Sub due()
Dim FileToOpen As Variant
Dim OpenBook As Workbook
FileToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If FileToOpen <> False Then
Application.Workbooks.OpenText _
Filename:=FileToOpen, _
DataType:=xlDelimited, _
comma:=True, Tab:=False, semicolon:=False, Space:=False, other:=False, _
fieldinfo:=Array(Array(1, xlTextFormat), Array(2, xlTextFormat))
ActiveSheet.UsedRange.Copy ThisWorkbook.Worksheets("BOM").Range("C1")
ActiveWorkbook.Close False
End If
End Sub
Note that you will need an array argument in FieldInfo for each column you want to be parsed as other than General, and no arguments for non-existent columns. See Microsoft VBA Help for the Workbooks.OpenText method for more information.
Original CSV
Pasted Values
Please, try the next code. It will use a different way of opening the text file. If the number of columns is not constant, the code will firstly count them and then build an array able to make the file opening as you need:
Sub openAsTextTextFormat()
Dim FileToOpen As Variant, arrTXT, nrCol As Long, arr(), i As Long
Dim OpenBook As Workbook
FileToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If FileToOpen <> False Then
'Check the number of text file columns:
arrTXT = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(FileToOpen, 1).ReadAll, vbLf)
nrCol = UBound(Split(arrTXT(0), vbTab))
'______________________________________
ReDim arr(nrCol) 'redim the format array
For i = 0 To nrCol
arr(i) = Array(1, 2) 'fill the format array with variant for TEXT Format!
Next
Workbooks.OpenText FileName:=FileToOpen, origin:=932, startRow:=1, DataType:=xlDelimited, _
other:=True, OtherChar:="|", FieldInfo:=arr()
Set OpenBook = ActiveWorkbook
Stop ' The code will stop here! Please, check if the text file has been open with the correct format.
OpenBook.Sheets(1).UsedRange.Copy ThisWorkbook.Worksheets("BOM").Range("C1")
OpenBook.Close False
End If
End Sub
You could try setting the format of the destination range.
Dim FileToOpen As Variant
Dim OpenBook As Workbook
Dim rng As Range
FileToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If FileToOpen <> False Then
Set OpenBook = Application.Workbooks.Open(FileToOpen)
Set rng = OpenBook.Sheets(1).UsedRange
With ThisWorkbook.Worksheets("BOM")
.Range("C1").Resize(rng.Rows.Count, rng.Columns.Count).NumberFormat = "#"
rng.Copy
.Range("C1").PasteSpecial xlPasteValues
End With
OpenBook.Close False
End If
You need to know how many digits are those numbers. This code, as example, makes all numbers to have 6 digits, so it adds leading zeros until len of string is 6.
Also, it will copy 1 column to another column.
Sub test()
Dim MiMatriz As Variant
Dim i As Long
Dim ZZ As Long
ZZ = 1 'first row where data is going to be pasted
MiMatriz = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
For i = 1 To UBound(MiMatriz) Step 1
MiMatriz(i, 1) = "'" & Format(MiMatriz(i, 1), "000000")
Next i
Range("C" & ZZ & ":C" & ZZ + UBound(MiMatriz) - 1) = MiMatriz
Erase MiMatriz
End Sub
As you can see in the image below, column A would be the original and column C, numbers with leading zeros.
You can adapt this code to fit your needs.
I'm using text to columns as part of a VBA macro to separate timestamps into 2 other columns. When I format Column B to dd/mm/yyyy it uses the current year 2020 instead of 2019. Is there a way to adjust my macro to pull the year from the original timestamp or alternatively, pull the year from Column C once Text to Columns has completed?
Range("A5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.TextToColumns Destination:=Range("A5"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 3), Array(2, 3), Array(3, 3)), TrailingMinusNumbers:=True
Range("B5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "dd/mm/yyyy;#"
Selection.TextToColumns Destination:=Range("B5"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(1, 8), TrailingMinusNumbers:=True
This uses arrays:
Sub mydatesplit()
With ActiveSheet
Dim arr As Variant
arr = .Range("A5", .Cells(.Rows.Count, 1).End(xlUp)).Value
Dim outArr() As Variant
ReDim outArr(1 To UBound(arr, 1), 1 To 3)
Dim i As Long
For i = 1 To UBound(arr, 1)
Dim spltStr() As String
spltStr = Split(Replace(arr(i, 1), ",", ""), " ")
If UBound(spltStr) >= 5 Then
outArr(i, 1) = spltStr(0)
outArr(i, 2) = DateValue(spltStr(2) & " " & spltStr(1) & " " & spltStr(3))
outArr(i, 3) = TimeValue(spltStr(4) & " " & spltStr(5))
End If
Next i
.Range("B5").Resize(UBound(outArr, 1), UBound(outArr, 2)).Value = outArr
End With
End Sub
After Running:
BTW with Dynamic Array formulas newly introduced into Excel with the latest subscription one can use fairly simple formula:
Date:
=--TEXTJOIN(" ",TRUE,INDEX(TRIM(MID(SUBSTITUTE(SUBSTITUTE(A5,",","")," ",REPT(" ",999)),(ROW($1:$7)-1)*999+1,999)),{3,2,4}))
Time
=--TEXTJOIN(" ",TRUE,INDEX(TRIM(MID(SUBSTITUTE(SUBSTITUTE(A5,",","")," ",REPT(" ",999)),(ROW($1:$7)-1)*999+1,999)),{5,6}))
Based on data in the screenshot you could use the following function to split the timestamp
Function convertTimestamp(ByVal inp As String) As Variant
Dim sDate As String, sTime As String, sTimezone As String, sDay As String
Dim v As Variant
v = Split(Replace(inp, ",", ""), " ")
sDate = DateValue(v(2) & " " & v(1) & " " & v(3))
sTime = TimeValue(v(4) & " " & v(5))
sTimezone = v(6)
sDay = v(0)
ReDim v(1 To 4)
v(1) = sDay
v(2) = CDate(sDate)
v(3) = sTime
v(4) = sTimezone
convertTimestamp = v
End Function
PS Adjusted the function based on Scott's excellent approach to split the string.
Either you use this function in the worksheet itself (as an array function!) or you use the following code to split the row 5 to 8 as in your screenshot
Sub TimeStampToCol()
Dim rg As Range
Set rg = Range("A5:A8")
Dim vDat As Variant
vDat = WorksheetFunction.Transpose(rg)
Dim rDat As Variant
ReDim rDat(1 To 4, 1 To 4)
Dim i As Long, v As Variant, j As Long
For i = LBound(vDat) To UBound(vDat)
v = convertTimestamp(vDat(i))
For j = 1 To 4
rDat(i, j) = v(j)
Next j
Next i
Set rg = Range("B5:E8")
rg.Value = rDat
End Sub
Usage as an array formula
I wrote VBA code that opens all of the .xls files in a folder, and copies and pastes desired information out of those files into a new workbook.
Each row in the new workbook is associated with a file from the folder.
Column1, Column2, Column3
FileName1, ABC, XYZ
FileName2, DEF, TUV
The info in Column3 has the formatting of
ArbitraryString1(Very_Important_Info)ArbitraryString2
Because I wanted Column3 to look nice, I iterated over every row and used
Range("C"&X).TextToColumns DataType:=xlDelimited, Other:=True _
OtherChar:="("
Columns("E:E").Insert Shift:=xlToRight *
Range("D"&X).TextToColumn DataType:=xlDelimited, Other:=True _
OtherChar:=")"
Range("C"&X).TextToColumns DataType:=xlDelimited, Other:=True _
OtherChar:="(" **
Columns("E:Z").Delete
Columns("C:C").Delete
*This is needed so when I call TextToColumn the second time I do not get a message asking if I want to overwrite what is already in that column.
I end up with
Column1, Column2, Column3
FileName1, ABC, Very_Important_Info_1
FileName2, DEF, Very_Important_Info_2
After calling OtherChar:="(" the first time I end up seeing
(Very_Important_Info)ArbitraryString2
with the left bracket still attached.
I call the method a second time or ColumnC would look like
(Very_Important_Info
Might work better with SPLIT
Sub TextToCols()
Dim rng As Range
Dim r As Range
Dim l As Long
Dim arr As Variant
With ActiveSheet
l = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rng = Range("C2:C" & l)
For Each r In rng
r.Value = Application.WorksheetFunction.Substitute(r.Value, ")", "(")
arr = Split(r.Value, "(")
Cells(r.Row, 3).Value = arr(1)
Next r
End With
End Sub
Or text-to-columns:
Sub TextToCols()
Dim rng As Range
Dim r As Range
Dim l As Long
With ActiveSheet
l = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rng = Range("C2:C" & l)
For Each r In rng
r.Value = Application.WorksheetFunction.Substitute(r.Value, ")", "(")
Next r
With .UsedRange.Columns("C").Cells
.TextToColumns Destination:=Range("C1"), _
DataType:=xlDelimited, _
OtherChar:="("
End With
End With
End Sub
Here is a simplified version of Michal Rosa's code:
Sub BeautifyIt()
With Worksheets("Sheet1")
With .Range("C2", .Range("C" & .Rows.Count).End(xlUp))
.Replace ")", "("
.TextToColumns Destination:=.Cells(1, 1), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, _
OtherChar:="(", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
End With
End With
End Sub
I have been trying to figure out how to take several hundred tab-delimited text files and import the data into subsequent columns of a single excel worksheet. The text files contain I(V) data with two columns and a header. I have found code/manipulated it to be able to remove the header and import into individual worksheets within a workbook but would like to be able to get the two columns of data from each worksheet into a single worksheet (i.e. columns from first text file to columns A & B of one worksheet, columns from second text file to columns C & D, etc.). Here is the code I am currently using:
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))
wkbTemp.Sheets(1).Copy
Set wkbAll = ActiveWorkbook
wkbTemp.Close (False)
wkbAll.Worksheets(x).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:="|"
Rows("1:20").Select
Selection.Delete Shift:=xlUp
x = x + 1
While x <= UBound(FilesToOpen)
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
With wkbAll
wkbTemp.Sheets(1).Move After:=.Sheets(.Sheets.Count)
.Worksheets(x).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
Rows("1:20").Select
Selection.Delete Shift:=xlUp
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
Here is an example of one of my I(V) data files:
Notes:
Timestamp: 7/19/2018 8:36:11 AM
Channel: Channel A
NPLC: 1
Current Limit: 0.010000
Pulse Mode: 0
Bias Pulses: 1
Bias Level: 0.000000
Settling Time: 0.500000
Voltage (V) Current (A)
-1.00000E+0 -6.95885E-7
-9.50000E-1 -6.47828E-7
-9.00000E-1 -6.06955E-7
-8.50000E-1 -5.53913E-7
-8.00000E-1 -5.00038E-7
-7.50000E-1 -4.51646E-7
-7.00000E-1 -4.02903E-7
-6.50000E-1 -3.58851E-7
-6.00000E-1 -3.19926E-7
-5.50000E-1 -2.73332E-7
-5.00000E-1 -2.33349E-7
-4.50000E-1 -1.99018E-7
-4.00000E-1 -1.62825E-7
-3.50000E-1 -1.31703E-7
-3.00000E-1 -1.04510E-7
-2.50000E-1 -8.06238E-8
-2.00000E-1 -5.88286E-8
-1.50000E-1 -4.14340E-8
-1.00000E-1 -2.58151E-8
-5.00000E-2 -1.24138E-8
0.00000E+0 5.52116E-11
5.00000E-2 1.26769E-8
1.00000E-1 2.64685E-8
1.50000E-1 4.17401E-8
2.00000E-1 5.97095E-8
2.50000E-1 7.98343E-8
3.00000E-1 1.02119E-7
3.50000E-1 1.28176E-7
4.00000E-1 1.57270E-7
4.50000E-1 1.89915E-7
5.00000E-1 2.29916E-7
5.50000E-1 2.72104E-7
6.00000E-1 3.35173E-7
6.50000E-1 4.53464E-7
7.00000E-1 6.12379E-7
7.50000E-1 7.97423E-7
8.00000E-1 9.75624E-7
8.50000E-1 1.16841E-6
9.00000E-1 1.34435E-6
9.50000E-1 1.52710E-6
1.00000E+0 1.75166E-6
1.00000E+0 1.81262E-6
9.50000E-1 1.72918E-6
9.00000E-1 1.63206E-6
8.50000E-1 1.52714E-6
8.00000E-1 1.42523E-6
7.50000E-1 1.32162E-6
7.00000E-1 1.21624E-6
6.50000E-1 1.11347E-6
6.00000E-1 1.00770E-6
5.50000E-1 9.05824E-7
5.00000E-1 8.08058E-7
4.50000E-1 7.09499E-7
4.00000E-1 6.14927E-7
3.50000E-1 5.26256E-7
3.00000E-1 4.38557E-7
2.50000E-1 3.53943E-7
2.00000E-1 2.74731E-7
1.50000E-1 1.98096E-7
1.00000E-1 1.27457E-7
5.00000E-2 6.16247E-8
0.00000E+0 -8.63841E-11
-5.00000E-2 -5.78634E-8
-1.00000E-1 -1.15769E-7
-1.50000E-1 -1.73858E-7
-2.00000E-1 -2.33503E-7
-2.50000E-1 -2.94364E-7
-3.00000E-1 -3.59336E-7
-3.50000E-1 -4.24816E-7
-4.00000E-1 -4.92460E-7
-4.50000E-1 -5.61514E-7
-5.00000E-1 -6.32542E-7
-5.50000E-1 -7.06702E-7
-6.00000E-1 -7.83559E-7
-6.50000E-1 -8.63077E-7
-7.00000E-1 -9.49685E-7
-7.50000E-1 -1.03839E-6
-8.00000E-1 -1.12932E-6
-8.50000E-1 -1.22503E-6
-9.00000E-1 -1.31770E-6
-9.50000E-1 -1.42892E-6
-1.00000E+0 -1.53654E-6
None of the header information is needed, which is why I am currently just deleting the first 20 rows. I have basic programming experience but very little with VBA. Any help with this particular problem is greatly appreciated!
-Tory
Try so:
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 = "|"
Set wkbAll = ActiveWorkbook
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
iDestCol=1
For x = 0 to Ubound(FilesToOpen)
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
wkbTemp.Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:="|"
wbkTemp.Range("A:B").Copy Destination:=wkbAll.Cells(1, iDestCol)
wkbTemp.Close (False)
iDestCol = iDestCol + 2
Next
Rows("1:20").Delete Shift:=xlUp
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
So, I managed to get two macros coded to do what I need. I have one for pulling the data in from selected text files into individual sheets and another to consolidate the sheets into columns of a single sheet. The code for the first macro is here:
Sub TextToSheets()
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
Name = Dir(FilesToOpen(x))
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
wkbTemp.Sheets(1).Copy
Set wkbAll = ActiveWorkbook
wkbTemp.Close (False)
wkbAll.Worksheets(x).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:="|"
Range("A19:B19").Select
ActiveCell.FormulaR1C1 = Name
Range("A20").Select
ActiveCell.FormulaR1C1 = "Voltage (V)"
Range("B20").Select
ActiveCell.FormulaR1C1 = "Current (A)"
Rows("1:18").Select
Selection.Delete Shift:=xlUp
x = x + 1
While x <= UBound(FilesToOpen)
Name = Dir(FilesToOpen(x))
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
With wkbAll
wkbTemp.Sheets(1).Move after:=.Sheets(.Sheets.Count)
.Worksheets(x).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
Range("A19:B19").Select
ActiveCell.FormulaR1C1 = Name
Range("A20").Select
ActiveCell.FormulaR1C1 = "Voltage (V)"
Range("B20").Select
ActiveCell.FormulaR1C1 = "Current (A)"
Rows("1:18").Select
Selection.Delete Shift:=xlUp
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
And for the second here:
Sub CombineSheetsToColumns()
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Summary").Delete
Application.DisplayAlerts = True
n = Application.Worksheets.Count
Sheets.Add.Name = "Summary"
Sheets("Summary").Move after:=Worksheets(Worksheets.Count)
Set MerPos = Range(Cells(1, 2), Cells(1, 3))
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "Summary" And sh.Name <> Sheets(n + 1).Name Then
Set col = Columns(Columns.Count).End(xlToLeft)
sh.Range("A:A,B:B").Copy Destination:=Sheets("Summary").Range(col, col).Offset(0, 1)
MerPos.Select
Selection.Merge
Set MerPos = Range(MerPos.Offset(0, 1), MerPos.Offset(0, 2))
End If
Next sh
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Sheets("Summary").Select
Cells.HorizontalAlignment = xlCenter
Columns.AutoFit = xlColumn
End Sub
I added a few lines for adding text and formatting but shouldn't be too hard to get it working for whatever you may need to use it for. Thanks for all the help!
If you want to copy/paste data across a sheet, run the code below.
Sub ReadFilesIntoActiveSheet()
Dim fso As FileSystemObject
Dim folder As folder
Dim file As file
Dim FileText As TextStream
Dim TextLine As String
Dim Items() As String
Dim i As Long
Dim cl As Range
' Get a FileSystem object
Set fso = New FileSystemObject
' get the directory you want
Set folder = fso.GetFolder("C:\Users\Excel\Desktop\Coding\LinkedIn\Import All Text Files Into One Single Sheet with File Name in Column A\")
' set the starting point to write the data to
'Set cl = ActiveSheet.Cells(1, 1)
Dim sht As Worksheet
Dim LastRow As Long
Set sh = ActiveSheet
' Loop thru all files in the folder
For Each file In folder.Files
' Write file-name
LastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row + 1
Range("A" & LastRow).Select
ActiveCell = file.Name
' open the file
Set txtFile = fso.OpenTextFile(file)
col = 2
Do While Not txtFile.AtEndOfStream
dat = Application.Transpose(Application.Index(Split(txtFile.ReadLine, ","), 1, 0))
sh.Cells(LastRow, col).Resize(UBound(dat), 1) = dat
col = col + 1
Loop
' Clean up
txtFile.Close
'Range(cl.Address).Offset(1, 0).Select
Next file
Set FileText = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
End Sub
If you want to copy/paste data down a sheet, run the code below.
Sub ReadFilesIntoActiveSheet()
Dim fso As FileSystemObject
Dim folder As folder
Dim file As file
Dim FileText As TextStream
Dim TextLine As String
Dim Items() As String
Dim i As Long
Dim cl As Range
' Get a FileSystem object
Set fso = New FileSystemObject
' get the directory you want
Set folder = fso.GetFolder("C:\Users\Excel\Desktop\Coding\LinkedIn\Import All Text Files Into One Single Sheet with File Name in Column A\")
' set the starting point to write the data to
Set cl = ActiveSheet.Cells(2, 1)
' Loop thru all files in the folder
For Each file In folder.Files
' Write file-name
cl.Value = file.Name
' Open the file
Set FileText = file.OpenAsTextStream(ForReading)
' Read the file one line at a time
Do While Not FileText.AtEndOfStream
TextLine = FileText.ReadLine
' Parse the line into | delimited pieces
Items = Split(TextLine, "|")
' Put data on one row in active sheet
For i = 0 To UBound(Items)
cl.Offset(0, 1 + i).Value = Items(i)
Next
' Move to next row
Set cl = cl.Offset(1, 0)
Loop
' Clean up
FileText.Close
Next file
Set FileText = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
End Sub
I havethe following problem:
To be able to deploy multiple devices, I have edited some VBA code I found here and there and I'm lost at the moment... Because I'm not a coder, and I don't understand exactly what the code does, I can't figure out the solution.
The problem is: when I add 1 device, the .csv file is cluttered with data:
HOSTNAMEHQ,COUNTRYCRE,HARDWARECRE,MAC,UUID,DESCRIPTION,PLATFORM
LPAB00000013293,,,28:F1:0E:30:81:C1,,STOCK,
#N/A,,,#N/A,,STOCK,
#N/A,,,#N/A,,STOCK,
#N/A,,,#N/A,,STOCK,
#N/A,,,#N/A,,STOCK,
#N/A,,,#N/A,,STOCK,
(etc)
When I add 2 or more devices, the .csv file is OK:
HOSTNAMEHQ,COUNTRYCRE,HARDWARECRE,MAC,UUID,DESCRIPTION,PLATFORM
LPAB00000013293,,,28:F1:0E:30:81:C1,,STOCK,
LPAB00000013293,,,28:F1:0E:30:81:C1,,STOCK,
The code I'm using is:
Sub Button_Click()
Call SaveWorksheetsAsCsv
End Sub
Sub SaveWorksheetsAsCsv()
On Error Resume Next
Dim i As Long
Errorknop = vbCritical + vbOKOnly
ThisWorkbook.Sheets("Export").Visible = xlSheetVisible
ThisWorkbook.Sheets("Export").Activate
Range("A1").Select
Selection.End(xlDown).Select
LaRo = ActiveCell.Row
Range("A1").Select
Range("A2").Select
Selection.End(xlDown).Select
LR = ActiveCell.Row
LC = Last(4, ActiveSheet.Cells)
LCR = LC & LR
Range("B1:" & LCR).Copy
ThisWorkbook.Sheets("Export").Visible = xlSheetHidden
ThisWorkbook.Sheets("Export_2").Visible = xlSheetVisible
ThisWorkbook.Sheets("Export_2").Activate
Range("A1").Select
Range("A1").PasteSpecial Paste:=xlPasteValues
Dim LValue As Date
LValue = Now
Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
Dim strbody As String
Dim SigString As String
Dim Signature As String
CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
SaveToDirectory = "D:\Testmap\Formulieren\"
Worksheets("Export_2").SaveAs Filename:=SaveToDirectory & Day(LValue) & Month(LValue) & Year(LValue) & Hour(LValue) & Minute(LValue) & Second(LValue) & "_1IMPORT_TEMPLATE_NN_AD_SCCM_HP", FileFormat:=xlCSV
ThisWorkbook.Saved = True
Application.Quit
End Sub
Function Last(choice As Integer, rng As Range)
' 1 = last row
' 2 = last column (R1C1)
' 3 = last cell
' 4 = last column (A1)
Dim lrw As Long
Dim lcol As Integer
Select Case choice
Case 1:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case 2:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
lcol = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Last = Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
Case 4:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Last = R1C1converter("R1C" & Last, 1)
For i = 1 To Len(Last)
s = Mid(Last, i, 1)
If Not s Like "#" Then s1 = s1 & s
Next i
Last = s1
End Select
End Function
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Function R1C1converter(Address As String, Optional R1C1_output As Integer, Optional RefCell As Range) As String
'Converts input address to either A1 or R1C1 style reference relative to RefCell
'If R1C1_output is xlR1C1, then result is R1C1 style reference.
'If R1C1_output is xlA1 (or missing), then return A1 style reference.
'If RefCell is missing, then the address is relative to the active cell
'If there is an error in conversion, the function returns the input Address string
Dim x As Variant
If RefCell Is Nothing Then Set RefCell = ActiveCell
If R1C1_output = xlR1C1 Then
x = Application.ConvertFormula(Address, xlA2, xlR1C1, , RefCell) 'Convert A2 to R1C1
Else
x = Application.ConvertFormula(Address, xlR1C1, xlA2, , RefCell) 'Convert R1C1 to A2
End If
If IsError(x) Then
R1C1converter = Address
Else
'If input address is A1 reference and A1 is requested output, then Application.ConvertFormula
'surrounds the address in single quotes.
If Right(x, 1) = "'" Then
R1C1converter = Mid(x, 2, Len(x) - 2)
Else
x = Application.Substitute(x, "$", "")
R1C1converter = x
End If
End If
End Function
For a coder this might be completely logical or even a big mess, but I really hope someone can give me the solution so the script runs, get's the information for the cells, and then stops when it finds an empty cell. At that moment, write the .csv file and close.
I found the solution using a step-by-step method with F8. Finding the last row was where the error was. Now I'm using:
Cells(Rows.Count, "A").End(xlUp).Row