Want to import bits (a couple of rows) of an .txt to excel - vba

Hey so i found a specific query to import a file into excel from a specific row and delete the following datga each time you open it again. but is it also pssible to stop adding rows at a specific line? and is it possible to leave some rows out if there for example is a specific word in that line?
Sub Sample()
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Users\sample.txt", Destination:=Range("$A$1") _
)
.Name = "Sample"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub

You can do it, but not with a Querytable.
Try this code:
Private Sub Open_Click()
Dim fn As Variant, myLine As Long, txt As String, x As Variant, ouput As String
Dim i As Integer, j As Integer: j = 1
Dim sht As Worksheet
Set sht = Worksheets("Sheet1") 'Modify Sheet Name
fn = Application.GetOpenFilename("Text Files (*.txt),*.txt", , _
"Open File")
If fn = False Then Exit Sub
txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
x = Split(txt, vbNewLine)
For i = 0 To UBound(x)
If x(i) <> "SomeCriteria" Then 'Check for some criteria
sht.Cells(j, 1).Value = x(i)
j = j + 1
End If
Next i
End Sub
So what it does basically, it opens a user selected txt file and stores it in the variable txt. Do seperate the rows you can use the split-function. Now each line is stored in an array x. You could go trough the array/each line and take out the ones you want. To check if a specific word is in a line, use the InStr-function.

Related

How do I get errors only for the files that error out

At my company we need to convert a lot of text files each month to excel and some of the columns we need to change the data types of the columns. They used to convert all of them manually which was very time consuming. I created an access program that they can do it in much easier. They just hit a button and it transfers them, with a running list of all the files converted. Some of the files will change here and there, so when running the program I have another list that is supposed to show all the files that cause an error. Unfortunately, what it does, at the moment, once it receives the error from one file - every file after that also says there is an error. So if there are 100 files witch file 5 and 25 as errors, it would still show all files from 5 to 100 are errors. Here is the code I am using:
Public Sub ImportTextFile(ByVal xl As Excel.Application, ByVal strFileName As String, ByVal iNumOfCols As Integer, Optional aDataTypes As Variant = Nothing)
On Error GoTo Sub_Err
Dim sPathAndFile As String: sPathAndFile = cPath & strFileName
Dim wb As Workbook: Set wb = xl.Workbooks.Add
Dim ws As Worksheet: Set ws = wb.Sheets(1)
With ws.QueryTables.Add(Connection:="TEXT;" & sPathAndFile & ".txt", Destination:=ws.Range("$A$1"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = GetColumnDataTypes(iNumOfCols, aDataTypes)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Call SaveFile(wb, sPathAndFile)
Forms("Dashboard").lbCompleted.AddItem strFileName
Forms("Dashboard").lbCompleted.Selected(Forms("Dashboard").lbCompleted.ListCount - 1) = True
Sub_End:
Set wb = Nothing
Set ws = Nothing
Err.Clear
Exit Sub
Sub_Err:
'MsgBox Err.Description
Forms("Dashboard").lbError.AddItem strFileName
Resume Sub_End
End Sub
and then each file calls back like this:
Call ImportTextFile(xl, "DGXC094P", 11)
Call ImportTextFile(xl, "DGAC081", 18, Array(, , , , , , , , , , , , , , , , , , 2))
I tried clearing the error but it doesn't clear. What am I doing wrong? How can I get it to show only the files that have errors?
Concerning the Sub to import the Textfile: Make it a function. Then you are able to give a callback if there was an error or not. Like this:
Public Function ImportTextFile(ByVal xl As Excel.Application, ByVal strFileName As String, ByVal iNumOfCols As Integer, Optional aDataTypes As Variant = Nothing) as string
On Error GoTo ErrorHandling
Dim sPathAndFile As String: sPathAndFile = cPath & strFileName
Dim wb As Workbook: Set wb = xl.Workbooks.Add
Dim ws As Worksheet: Set ws = wb.Sheets(1)
With ws.QueryTables.Add(Connection:="TEXT;" & sPathAndFile & ".txt", Destination:=ws.Range("$A$1"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = GetColumnDataTypes(iNumOfCols, aDataTypes)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Call SaveFile(wb, sPathAndFile)
Forms("Dashboard").lbCompleted.AddItem strFileName
Forms("Dashboard").lbCompleted.Selected(Forms("Dashboard").lbCompleted.ListCount - 1) = True
Set wb = Nothing
Set ws = Nothing
ImportTextFile = "ok"
Exit Function
ErrorHandling:
Set wb = Nothing
Set ws = Nothing
ImportTextFile = Err.Description
End Function
Your procedure to call the function should look like this:
Dim ImportResult as string
ImportResult = ImportTextFile(xl, "DGAC081", 18, Array(, , , , , , , , , , , , , , , , , , 2))
'Case Import Error
If ImportResult <> "ok" then
MsgBox (ImportResult)
Forms("Dashboard").lbError.AddItem strFileName
end if
'Case Import OK
If ImportResult = "ok" then
'What you want
end if
When using a function instead of a sub you will be able to treat each import individually.

How can VBA read CSV with breakline inside double quote?

I'm trying to upload a CSV file with breaklines inside quotes (data.csv) but instead of putting all the text inside the quote in one cell, it still considers it as a new row.
When I open the CSV directly, everything works fine but when I run it through VBA, everything is getting messed up.
data.csv sample
cases,"variant:
option1: 0333102
option2: 1133202
option3: 4234442"
make-shift,"variant:
option1: shift iron
option2: workload
option3: network map
option4: lesson map"
Import_CSV Function
Function import_CSV(location As String, row As Integer, col As String) As Variant
Dim ws As Worksheet, strFile As String
Sheets("data").Visible = True
Sheets("data").UsedRange.ClearContents
Set ws = Sheets("data")
strFile = location
With ws.QueryTables.Add(Connection:="TEXT;" & strFile, Destination:=ws.Range("A1"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
import_CSV = Sheets("data").Range(col & "1:" & Get_C(Last_C(row, "data")) & Last_R(Get_C(Last_C(row, "data")), "data"))
Sheets("data").Visible = False
End Function
Assuming your import_CSV() returns the range in data worksheet with same size as the imported CSV, try below. Don't really need the row integer and col string, so I have omitted it.
Option Explicit
Function ImportCustomCSV(location As String) As Range
Dim oWbCSV As Workbook, oRngCSV As Range, oRngData As Range
ThisWorkbook.Worksheets("data").UsedRange.ClearContents
' Range to start pasting csv data
Set oRngData = ThisWorkbook.Worksheets("data").Range("A1")
' Assumes file availability is already checked
Set oWbCSV = Workbooks.Open(Filename:=location, ReadOnly:=True)
Set oRngCSV = oWbCSV.Worksheets(1).UsedRange
' Copy the CSV range to data worksheet
oRngCSV.Copy oRngData
' Make the data range the same rows and cols as imported csv
Set oRngData = oRngData.Resize(oRngCSV.Rows.Count, oRngCSV.Columns.Count)
' Cleanup
Set oRngCSV = Nothing
oWbCSV.Close SaveChanges:=False
Set oWbCSV = Nothing
' Return the updated data range
Set ImportCustomCSV = oRngData
End Function

How to read from a text (.txt) file and place data into an excel 2016 document using VBA Macros editor?

I need to read the following text document (see first picture):
and place data into an excel document in the pictured manner (see second image):
I want to do this with an Excel VBA macros but I do not have the slightest idea on how to do so. I am very new to excel VBA and I do not have the slightest idea on where to begin.
Use following sub.
Sub txtImport()
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Users\HARUN\Documents\Test.txt", Destination:=Range("$A$1"))
.Name = "Test"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = True
.TextFileColumnDataTypes = Array(1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
This code will do that without looping and regardless of number of spaces between the columns.
Sub Test()
Dim Fn As String, WS As Worksheet, st As String
Fn = "D:\tttt\test.txt" ' the file path and name
Set WS = Sheets("Sheet1")
'Read text file to st string
With CreateObject("Scripting.FileSystemObject")
If Not .FileExists(Fn) Then
MsgBox Fn & " : is missing."
Exit Sub
Else
If FileLen(Fn) = 0 Then
MsgBox Fn & " : is empty"
Exit Sub
Else
With .OpenTextFile(Fn, 1)
st = .ReadAll
.Close
End With
End If
End If
End With
'Replace every one or more space in st string with vbTab
With CreateObject("VBScript.RegExp")
.Pattern = "[ ]+"
.Global = True
.Execute st
st = .Replace(st, vbTab)
End With
'Put st string in Clipboard
With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText st
.PutInClipboard
End With
'Paste Clipboard to range
WS.Range("A1").PasteSpecial
End Sub
Let's suppose you have csv file (like you have shown, just difference is in delimiters), then the code should be:
Sub ReadData()
Dim line, array() As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set rfile = FSO.OpenTextFile(*your full path to the file*, 1) 'connection for reading
Dim i As Integer
i = 1
Do Until rfile.AtEndOfStream
line = rfile.ReadLine
array = Split(line, ",") 'I assumed that delimiter is comma
For j = 0 To UBound(array)
Cells(i, j + 1).Value = array(j)
Next j
i = i + 1
Loop
rfile.Close
End Sub

Excel VBA trouble looping through sheets and calling subroutine

My subroutine works fine when I run it on individual sheets, but I've had a lot of problems getting it to run on each individual sheet. The Subroutine is a simple query of an online CSV database, but it only executes 25 times on the first sheet. can't figure out for the life of me why this is.
I was able to do calculations through this same loop, but could not get it to run a subroutine on each sheet.
Sub Datacollection()
Dim ws As Worksheet
For Each ws In Worksheets
ws.Application.Run "Gethistory"
Next ws
End Sub
Sub Gethistory()
Dim Target As Variant
Dim Name As Variant
'
Set Target = Range("B1")
Set Name = Range("B2")
With ActiveSheet.QueryTables.Add(Connection:= _
"Text;" & Target, _
Destination:=Range("$A$3"))
.Name = Name
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = True
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
Gather the worksheet to be processed in your primary loop and pass that to the getHistory sub as a parameter.
Option Explicit
Sub dataCollection()
Dim w As Long
For w = 1 To Worksheets.Count
getHistory Worksheets(w)
Next w
End Sub
Sub getHistory(ws As Worksheet)
Dim trgt As Range, nm As Range
With ws
Set trgt = .Range("B1")
Set nm = .Range("B2")
With .QueryTables.Add(Connection:= _
"Text;" & trgt.Value, _
Destination:=.Range("$A$3"))
.Name = nm.Value
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = True
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End With
End Sub
If you do this repeatedly, you will end up with a lot of connections that could interfere in the general workbook efficiency as well as future getHistory runs. You might want to delete the connections as you create them or only use a refresh method to maintain the data.

Importing csv to Excel, CSV

I have a excel 2007 workbook , with current worksheet named 'a' Now what I want is,
When user clicks a button in sheet a, it should ask,
Which csv file to import,
Ask for name of that new sheet user want (where that csv file is to be placed).. Say to simplify user says 'b' now.
After that copy 'sheet a' into the new sheet b.
Import the csv into that new sheet, comma delimted, and allow overwriting of existing cells in copied sheet.
What can be basic start level code to accomplish all these tasks?
I will be grateful for any help in this regard.
Thanks
Sal
Try this:
Public strFile As String
Sub Main()
Dim WS As Worksheet
strFile = Application.GetOpenFilename("Excel workbooks,*.csv*")
If strFile = "False" Then
' the user clicked Cancel
Else
y = Right(strFile, Len(strFile) - InStrRev(strFile, "\", -1, vbTextCompare))
zz = Left(y, InStr(1, y, ".", vbTextCompare) - 1)
flag = 0
For k = 1 To Worksheets.Count
If Sheets(k).Name = zz Then
flag = 1
End If
Next
Set WS = Sheets.Add(After:=Sheets(Worksheets.Count))
If flag = 0 Then
WS.Name = zz
Else
MsgBox ("Sheet with same name already exist. Imported to default sheet")
End If
importcsv
End If
End Sub
Sub importcsv()
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & strFile, Destination:=Range( _
"$A$1"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub