Import multiple file .blst (look like .csv) to excel - excel

I want to import multiple file .blst into one worksheet and want to place .blst files horizontally in a worksheet. Which one file will place separate about 23 column such as first file place in column A1 - W1 and second X1- AT1 continue ...n file. But my code cannot open them.
This below code is Convert to Letter function
Function ConvertToLetter(iCol As Integer) As String
Dim iAlpha As Integer
Dim iRemainder As Integer
iAlpha = Int(iCol / 27)
iRemainder = iCol - (iAlpha * 26)
If iAlpha > 0 Then
ConvertToLetter = Chr(iAlpha + 64)
End If
If iRemainder > 0 Then
ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
End If
Debug.Print ConvertToLetter & 1
End Function
This below code is import wizard function
Function import_wizard(xFileName, xAddress) As String
With ActiveSheet.QueryTables.Add("TEXT;" & xFileName, Range(xAddress))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 936
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = ";"
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Function
This below code is button to browse and import multi file .blst
Private Sub browseXML_Click()
Dim xFileName As Variant
Dim xAddress As String
Dim countFile As Integer
On Error GoTo ErrHandler
xFileName = Application.GetOpenFilename(FileFilter:="blst Files,*.*", Title:="Select file", MultiSelect:=True)
If IsArray(xFileName) Then
'Msg = vbNewLine
For i = LBound(xFileName) To UBound(xFileName)
Msg = Msg & xFileName(i) & vbCrLf
countFile = i + 23
xAddress = ConvertToLetter(countFile) & "1"
SplitterMark.TextBox1.Value = Msg
Call import_wizard(xFileName, xAddress)
'Debug.Print "X = " & xAddress
Next i
Else
MsgBox "No files were selected."
GoTo ExitHandler
End If
ExitHandler:
ErrHandler:
End Sub
When i tired to comment ' Call import_wizard(xFileName, xAddress) the code can select multi file and can show on UI, but tired to delete comment Call import_wizard(xFileName, xAddress) can select multi file but it is show only last file from select and not open them file. I not sure it not do ActiveSheet.QueryTables.Add("TEXT;" & xFileName, Range(xAddress)) or not. Could someone please to suggest? Thanks

You need the "(i)" to select each individual file in this code row:
Call import_wizard(xFileName(i), ...
You don't need your "ConvertToLetter" function to convert a column number to the address.
I suggest to calculate the next import column like this:
...
Dim NextColumn As Long
For i = LBound(xFileName) To UBound(xFileName)
NextColumn = (i - 1) * 23 + 1
Call import_wizard(xFileName(i), NextColumn)
Next i
...
Your import routine then has to start like this:
Function import_wizard(ByVal xFileName as String, NextColumn as Long) As String
With ActiveSheet.QueryTables.Add("TEXT;" & xFileName, ActiveSheet.Cells(1, NextColumn))
...

Related

VBA - Query Table - Getting data from google sheet

I have a function i mostly found on web, to get a table from Google Sheets.
Sub GetDataFromGoogle(wsn As String, address As String)
Dim i As Integer
With Worksheets(wsn)
With .QueryTables.Add(Connection:="URL;" & address, Destination:=.Range("$A$1"))
.PreserveFormatting = False
.BackgroundQuery = True
.WebFormatting = xlWebFormattingNone
.Refresh BackgroundQuery:=False
End With
DoEvents
End With
For i = 1 To ThisWorkbook.Connections.Count
If ThisWorkbook.Connections.Count = 0 Then Exit Sub
ThisWorkbook.Connections.item(i).Delete
i = i - 1
Next i
End Sub
It seems to work well, but as i develloped my data base, a problem happened.
I only get the first 100 entries of my google sheet, then i got a empty line, a strange text on the first next range, and then the line under in position 3 the word List
I have no idea of what it is.
Sub Uygula()
Sheets("Veri").Range("A1:D600").ClearContents
Call GetDataFromGoogle("Veri", "18I8Vddjir3lFvtUorMln4mXlYNsY0KZtBGywVreped4")
End Sub
Sub GetDataFromGoogle(wsn As String, adres As String)
Dim i As Integer
Dim qry As String
Dim myURL As String
qry = Application.EncodeURL("SELECT A, C, G, B")
myURL = "https://docs.google.com/spreadsheets/d/" & adres & "/gviz/tq?tqx=out:csv&sheet=1&tq=" & qry
With Worksheets(wsn)
With .QueryTables.Add(Connection:="TEXT;" & myURL, Destination:=.Range("$A$1"))
.Name = "myTable"
.TextFilePlatform = 65001
.SaveData = False
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.Refresh BackgroundQuery:=False
End With
'DoEvents
End With
'For i = 1 To ThisWorkbook.Connections.Count
'If ThisWorkbook.Connections.Count = 0 Then Exit Sub
'ThisWorkbook.Connections.Item(i).Delete
'i = i - 1
'Next i
End Sub

Unnecessary value concatenation and Type Errors in Excel VBA

My VBA code takes a .txt file from a specific software output (Carlson Survey software) and does some calculations, then converts it into a .CSV file. I am specifically having issues with the calculation component, where one of my columns of the text file (brought into excel using comma separators) isn't doing the calculation I tell it, and is seemingly concatenating itself (removes everything after the decimal point). My assumption is, that because I am taking these values into an Array (which had to be set as string, or else I was getting type errors) which is set as a string, this is causing the concatenation after the decimal point. I am at a loss as to why the calculation doesn't appear to be running though, as the program seemingly executes fine.
And the VBA script for quick reference (specific section with problem is the 'Do data conversion' section:
Private Sub Workbook_Open()
Sheets("Sheet1").Cells.ClearContents
'---------------------------------------------------------------------------------------
'Choose and open the .TXT file for conversion
Dim answer As Integer
answer = MsgBox("Do you want to process a .TXT file for use in InfoSWMM?", vbYesNo + vbQuestion, "Select .TXT File")
If answer = vbNo Then
Exit Sub
End If
Dim Ret
Ret = Application.GetOpenFilename("Text Files (*.txt),*.txt")
If Ret <> False Then
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & Ret, 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)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End If
'---------------------------------------------------------------------------------------
'Do data conversion, SECTION NEEDS UPDATING LACKING FEATURES, BUGS
Dim row As Integer
Dim col As Integer
Dim i As Integer
Dim tester(3) As String 'Bug[1] related, type error (see below). String type fixes type error, but causes undesired concatenation
Dim col_test As Integer
Dim rim As Integer
For row = 1 To ActiveSheet.UsedRange.Rows.Count
If IsEmpty(ActiveSheet.Cells(row, 1).Value) = True Then
Exit For
End If
'Change these values in case feature code library is changed in Carlson, also need to add extra fields
If ActiveSheet.Cells(row, 5).Value = "SD" Or ActiveSheet.Cells(row, 5).Value = "WQ" Then
col_test = 20
rim = ActiveSheet.Cells(row, 4).Value
For i = 0 To 3
tester(i) = ActiveSheet.Cells(row, col_test).Value 'Bug[1] here, type error if not a String.
col_test = col_test + 4
Next i
ActiveSheet.Cells(row, 37).Value = rim - Application.Max(tester) 'Bug[2] here, not performing calculation.
End If
Next row
'---------------------------------------------------------------------------------------
'Save converted file as .CSV
MsgBox "Choose the desired save location for the .CSV file."
Dim InitialName As String
Dim PathName As Variant
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
InitialName = "sfm_output"
PathName = Application.GetSaveAsFilename(InitialFileName:=InitialName, fileFilter:="CSV (Comma delimited) (*.csv), *.csv")
ws.Copy
ActiveWorkbook.SaveAs Filename:=PathName, _
FileFormat:=xlCSV, CreateBackup:=False
MsgBox "Process completed successfully." & vbNewLine & "File saved to:" & vbNewLine & PathName
'---------------------------------------------------------------------------------------
'Close all Workbooks
Application.DisplayAlerts = False
Application.Quit
End Sub
Any help is greatly appreciated. Thanks.
Have you tried CSTRING or CINT functions?
For example:
tester(i) = CString(ActiveSheet.Cells(row, col_test).Value)

How to look up files (.txt) in a folder, import delimited data from file into excel, then move txt file to archive?

I've got a folder that will be populated by files with common characters but with a single digit variance, i.e. Test 34, or Test 40. The folder can be empty or contain 50 files.
I'm trying to write code that can:
go to folder check if folfer is empty, if not
take each text file and import space delimited data into excel (ideally based on date of file modification in folder - haven't gotten that far yet.)
Move files to archive folder (may cause me issues if file name already exists in archive)
if folder empty, exit/end sub
I've tried various methods, however my VBA knowledge isn't great. Below is a version of my code that has been spliced with various code from stackoverflow
Sub ImportFiles()
Dim eRow As String
Dim fileName As String
Dim rowNumber As String
Dim outputSheet As String
Dim sheetName As String
Dim folder As String
Dim strPath As Variant
Dim i As Integer
Dim fCount As Long
folder = "U:\Projects\Raw data\"
outputSheet = "Dataset"
fCount = UBound(Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & folder & "*.*"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")) + 1
'MsgBox Format(fCount, "#,00") & " files were found."
If Dir(folder & "*.*") = "" Then
MsgBox "The folder doesn't contain (visible) files"
MsgBox "Bye Bye!!"
Exit Sub
Else
'MsgBox "The folder does contain (visible) files"
For i = 0 To 11
fileName = folder & "Test" & i & ".txt"
'If Dir(fileName) = "" Then
eRow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
With Sheets(outputSheet).QueryTables.Add(Connection:="TEXT;" + fileName, Destination:=Sheets(outputSheet).Range("$A$" + eRow))
.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 = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = True
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Dim wb_conection As WorkbookConnection
For Each wb_Connection In ActiveWorkbook.Connections
If InStr(fileName, wb_Connection.Name) > 0 Then
wb_Connection.Delete
End If
Next wb_Connection
Next i
End If
MsgBox ("Done")
End Sub

import multiple csv to excel vba

I want to Import multiples csv file to excel sheet
but when the second csv file open the data of the first csv lost .
Here is my code:
Sub Test_ImportAllFiles()
Dim vaArray As Variant
Dim i As Integer
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
sPath = Application.ThisWorkbook.Path & "\cdr"
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sPath)
Set oFiles = oFolder.Files
If oFiles.Count = 0 Then Exit Sub
ReDim vaArray(1 To oFiles.Count)
i = 1
For Each oFile In oFiles
vaArray(i) = Application.ThisWorkbook.Path & "\cdr\" & oFile.Name
row_number = CStr(Cells(Rows.Count, 1).End(xlUp).Row)
With Sheets("Sheet2").QueryTables.Add("TEXT;" + vaArray(i), Destination:=Sheets("Sheet2").Range("$A$" + row_number))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 3
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Dim wb_connection As WorkbookConnection
For Each wb_connection In ActiveWorkbook.Connections
If InStr(vaArray(i), wb_connection.Name) > 0 Then
wb_connection.Delete
MsgBox "Antonis" & i
End If
Next wb_connection
i = i + 1
Next
End Sub
When you count the number of rows, you are referring to the active sheet, and that's possibly not the sheet where you want to write the data to.
Try something like
Dim x as long
With Sheets("Sheet2")
row_number = .Cells(.Rows.Count, 1).End(xlUp).Row)
if row_number > 1 then row_number = row_number + 1
end With
With Sheets("Sheet2").QueryTables.Add("TEXT;" + vaArray(i), _
Destination:=Sheets("Sheet2").Range("$A$" & row_number))
Update: Add one to row_number, else the ranges will overlap, and as a QueryTable may not overlap, Excel moves them.
And yes, you can use a number for the rowcount variable, you just have to change the string concatenation from + to &. The operator + works for concatenation only if both sides are strings, while & does an implicit conversion to string for all data types.

Insert top x rows from text with VBA

I want to insert the top x rows from a text file. I can give the number of the StartRow, but is there such parameters where I can give the "EndRow" number to give the top x rows what I want to inseret.
Sub insertTopX()
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Users\HarrsionDavid\Desktop\AnswerForEveryQuestions" _
,Destination:=Cells(1,1))
.Name = "test_file.txt"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
You can read the txt file and split it by new line. Then you would have an array which can be easy to work with.
Sample file:
Read the file and parse it to a variant;
Pass the startRow and the endRow;
Option Explicit
Public Sub TestMe()
Dim filePath As String
filePath = "C:\Users\user\User\nt.txt"
Dim myFile As String
myFile = ReadFileLineByLineToString(filePath)
Dim startRow As Long
Dim endRow As Long
Dim fixedFile As Variant
fixedFile = Split(myFile, vbCrLf)
startRow = 2
endRow = 3
Dim cnt As Long
For cnt = startRow To endRow
Debug.Print fixedFile(cnt - 1)
Next cnt
End Sub
This is the result:
This is the ReadFileLineByLineToString:
Public Function ReadFileLineByLineToString(path As String) As String
Dim fileNo As Long
fileNo = FreeFile
Open path For Input As #fileNo
Do While Not EOF(fileNo)
Dim textRowInput As String
Line Input #fileNo, textRowInput
ReadFileLineByLineToString = ReadFileLineByLineToString & textRowInput
If Not EOF(fileNo) Then
ReadFileLineByLineToString = ReadFileLineByLineToString & vbCrLf
End If
Loop
Close #fileNo
End Function

Resources