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.
Related
My Excel reads a CSV file to get data for a grid table.
"header", "header", "header", "header"
"value1",
"value2", "value3", "value4"
"value5", "value6", "value7", "value8"
"value9", "value10", "value11", "value12"
I want to read the second and third line of the CSV as the first row of the grid table.
Other lines are read one by one.
My code is:
Dim FileName As String, folder As String
folder = ThisWorkbook.Path & "\"
FileName = Dir(ThisWorkbook.Path & "\*.csv")
With ActiveSheet.QueryTables _
.Add(Connection:="TEXT;" & folder & FileName, Destination:=ActiveCell)
.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:=True
End With
My approach:
I am trying to modify the csv file with a new one that will have the second and third line merged as the second line.
filePath = folder & fileName
Dim fName As String, fso As Object, fsoFile As Object, txt As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
Set fsoFile = fso.OpenTextFile(filePath, 1)
txt = fsoFile.ReadAll
fsoFile.Close
txt = Split(txt, vbNewLine)
txt(2 - 1) = "some text with special characters like & Char(44) & and & Chr(10) & and so on"
Set fsoFile = fso.OpenTextFile(filePath, 2)
fsoFile.Write Join(txt, vbNewLine)
fsoFile.Close
the problem is that the grid table displays the special characters as & Char(44) & and & Char(10) & inside the cells...
Three methods for combining 2nd and 3rd lines
Sub merge23()
Dim fso As Object, tsIn, tsOut
Dim s As String
Set fso = CreateObject("Scripting.Filesystemobject")
Set tsIn = fso.OpenTextFile("C:\temp\test.csv", 1)
Set tsOut = fso.CreateTextFile("C:\temp\test1.csv", 1)
' method 1
Do While tsIn.AtEndOfLine <> True
s = tsIn.readline
If tsIn.Line <> 3 Then
s = s & vbCrLf
End If
tsOut.write s
Loop
tsIn.Close
tsOut.Close
' method 2
Set tsIn = fso.OpenTextFile("C:\temp\test.csv", 1)
s = tsIn.readall
tsIn.Close
s = Replace(s, vbCrLf, "~#~#~", 1, 1) 'mark 1st crlf
s = Replace(s, vbCrLf, "", 1, 1) ' replace 2nd
s = Replace(s, "~#~#~", vbCrLf, 1, 1) ' replace 1st crlf
Set tsOut = fso.CreateTextFile("C:\temp\test2.csv", 1)
tsOut.writeline s
' method 3 regex
Dim regex
Set regex = CreateObject("vbscript.regexp")
With regex
.Global = False
.MultiLine = True
.Pattern = "^(.*\r\n.*)\r\n" ' 2nd crlf
End With
Set tsIn = fso.OpenTextFile("C:\temp\test.csv", 1)
s = tsIn.readall
tsIn.Close
Set tsOut = fso.CreateTextFile("C:\temp\test3.csv", 1)
s = regex.Replace(s, "$1")
tsOut.writeline s
tsOut.Close
End Sub
I have asked a question regarding on how do I import the data in the respective columns. I received helped and the code works when it is imported into sheet1 which is where my import file button is located.
However, when I change with activesheet to with worksheets("RawData"), the imported file data will not be placed in the respective columns.
For example, file A will go to column A and column B while file B will go to column C and column D.
Sub ImportFiles()
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
Dim path As String
Dim filename As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Dim vrtSelectedItem As Variant
With fd
.AllowMultiSelect = True
'Set the initial path to the C:\ drive.
.InitialFileName = ActiveWorkbook.path
'Add a filter that includes the list.
.Filters.Clear
.Filters.Add "Text Files", "*.txt", 1
'The user pressed the button.
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
path = Left(vrtSelectedItem, InStrRev(vrtSelectedItem, "\"))
filename = Right(vrtSelectedItem, Len(vrtSelectedItem) - InStrRev(vrtSelectedItem, "\"))
Call Importfile(path, filename)
Next vrtSelectedItem
Else
End If
End With
Set fd = Nothing
End Sub
Sub Importfile(path As String, filename As String)
Dim Target As Range
Dim C As Long
'Sheets.Add(After:=Sheets("Sheet1")).Name = "RawData"
'ActiveSheet.Name = filename
On Error Resume Next
With Worksheet("RawData")
C = .Cells(1, .Columns.Count).End(xlToLeft).Column
If C > 1 Then C = C + 1
Set Target = .Cells(1, C)
With .QueryTables.Add(Connection:="TEXT;" & path & filename, _
Destination:=Target)
.Name = filename
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = False
.AdjustColumnWidth = False
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileOtherDelimiter = vbTab
.TextFileDecimalSeparator = "."
.TextFileThousandsSeparator = " "
.Refresh BackgroundQuery:=False
End With
End With
End Sub
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
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))
...
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