Thankyou for the time to click on this question. Ive been having problems with placing this data set on my vba code. I always keep on getting a file 'overflow' then a 'file already opened' error. The data set I am using is a data recordings of power consumption over time. And this set of data is meant to be put into 7 arrays. These are the datasets.
https://data.world/databeats/household-power-consumption
What is wrong with my code? Any suggestions?
Thankyou.
My code so far
Dim ID(50) As String, Day(50) As Date
Dim Time(50) As Integer, GlobelActivePower(50) As Integer
Dim Sub1(50) As Integer, Sub2(50) As Integer, Sub3(50) As Integer
Public N As Integer
Sub ReadFileSmall()
Dim Infile As String
Infile = ThisWorkbook.Path & "\Power_smallDataset.csv"
Open Infile For Input As #1
N = 0
Do Until EOF(1)
Input #1, ID(N), Day(N), Time(N), GlobelActivePower(N), Sub1(N),
Sub2(N), Sub3(N)
N = N + 1
Loop
Range("A4").Select
For indx = 0 To N - 1
ActiveCell.Offset(indx, 0).Value = ID(indx)
ActiveCell.Offset(indx, 1).Value = Day(indx)
ActiveCell.Offset(indx, 2).Value = Time(indx)
ActiveCell.Offset(indx, 4).Value = GlobelActivePower(indx)
ActiveCell.Offset(indx, 5).Value = Sub1(indx)
ActiveCell.Offset(indx, 6).Value = Sub2(indx)
ActiveCell.Offset(indx, 7).Value = Sub3(indx)
Next
Close #1
End Sub
The array size is strange.
The following is the data of the csv file.
Sub ReadFileSmall()
Dim Infile As String
Dim vDB
Infile = ThisWorkbook.Path & "\Power_smallDataset.csv"
Workbooks.Open Filename:=Infile, Format:=2
With ActiveSheet
vDB = .UsedRange
End With
ActiveWorkbook.Close (0)
Range("A4").Resize(UBound(vDB, 1), ubouns(vDB, 2)) = vDB
End Sub
Related
I am using the code below to generate the single file for selected range and considering the first cell in the selected range as file name. Please find the image below for more details[This image shows the selected range,Consider K column(Firstline) and N Column( Lastline) to be in one file and other set of 1st and last line in other file ]this image shows the print file for a single file this is the way m currently using for generating files.I need to create more 30k files so please help me to create more files in single click considering the first and last line as header and footer for the file
Private Sub CommandButton1_Click()
Dim myFile As String, rng As Range, cellValue As Variant, i As Integer, j As Integer, path As String, filename, filename2 As String
path = "D:\Watchlist-Files\"
filename = Selection.Cells(1, 1).Value
filename2 = Left(Mid(filename, 32, 99), Len(Mid(filename, 32, 99)) - 2)
myFile = path & filename2
Set rng = Selection
Open myFile For Output As #1
For i = 1 To rng.Rows.Count
For j = 1 To rng.Columns.Count
cellValue = rng.Cells(i, j).Value
If j = rng.Columns.Count Then
Print #1, cellValue
Else
Print #1, cellValue,
End If
Next j
Next i
Close #1
End Sub
The code below is using a Loop that scans rows in a range that consists of Columns K:N (according to your attached screen-shots).
Assumptions made: your FirstLine is in Column K, and it's the marker of the start position of copying the first cell in the first row.
Your LastLine is in Column N, and it's the marker of the last cell to copy, this is why I am closing the file once it is found.
Edit 1: added a Msgbox to allow the user selection of exporting the entire range or not. In case the user selected NO, then a second InputBox appears that allows the user to enter manually the last row number to export.
Option Explicit
Public Sub CommandButton1_Click()
Dim myFile As String
Dim rng As Range
Dim cellValue As Variant
Dim i As Long
Dim j As Long
Dim LastRow As Long
Dim path As String
Dim filename As String
Dim response As Boolean
path = "D:\Watchlist-Files\"
response = MsgBox("Do you want to Export the entire Range ? ", vbYesNo)
' Export the entire Range
If response = vbYes Then
LastRow = Cells(Rows.Count, "N").End(xlUp).Row
Else ' enter in the inputbox the last row number you want to export
LastRow = InputBox("Enter Last Row Number you wsnt to Export")
End If
Set rng = Range("K2:N" & LastRow)
For i = 2 To LastRow
' Column K holds the file name
If Cells(i, 11) <> "" Then
filename = Left(Mid(Cells(i, 11).Value, 32, 99), Len(Mid(Cells(i, 11).Value, 32, 99)) - 2)
myFile = path & filename
Open myFile For Output As #1
End If
For j = 1 To rng.Columns.Count
cellValue = Cells(i, 10 + j).Value
If j = rng.Columns.Count Then
Print #1, cellValue
' found LastLine >> close the file
If Not cellValue = "" Then
Close #1
End If
Else
Print #1, cellValue,
End If
Next j
Next i
End Sub
Edit 2: Added new code below (to keep the first option valid). The user needs to confirm that every selection he makes start and ends with FirstLine and LastLine , there is no error handling.
Option Explicit Section
Option Explicit
Dim filename As String
Dim path As String
Dim myFile As String
Dim rng As Range
Dim j As Long
Public Sub CommandButton1_Click
Public Sub CommandButton1_Click()
Dim lastRow As Long
Dim Sel_Range As Long
Dim response As Boolean
Dim rowStart() As Long
Dim rowFinish() As Long
path = "D:\Watchlist-Files\"
response = MsgBox("Do you want to Export only the Selected Range ? ", vbYesNo)
If response = True Then
Set rng = Selection
ReDim rowStart(1 To Selection.Areas.Count)
ReDim rowFinish(1 To Selection.Areas.Count)
For Sel_Range = 1 To Selection.Areas.Count
rowStart(Sel_Range) = Selection.Areas(Sel_Range).Row
rowFinish(Sel_Range) = Selection.Areas(Sel_Range).Row + Selection.Areas(Sel_Range).Rows.Count - 1
Call CreateTextFiles(rowStart(Sel_Range), rowFinish(Sel_Range))
Next Sel_Range
Else ' export the entire Range in Columns K:N
lastRow = Cells(Rows.Count, "N").End(xlUp).Row
Set rng = Range("K2:N" & lastRow)
Call CreateTextFiles(2, lastRow)
End If
Sub CreateTextFiles(Sel_StartRow As Long, Sel_FinishRow As Long) - new routine to allow handling of multiple Ranges selection
Sub CreateTextFiles(Sel_StartRow As Long, Sel_FinishRow As Long)
Dim i As Long
Dim cellValue As Variant
For i = Sel_StartRow To Sel_FinishRow
' Column K holds the file name
If Cells(i, 11) <> "" Then
filename = Left(Mid(Cells(i, 11).Value, 32, 99), Len(Mid(Cells(i, 11).Value, 32, 99)) - 2)
myFile = path & filename
Open myFile For Output As #1
End If
For j = 1 To rng.Columns.Count
cellValue = Cells(i, 10 + j).Value
If j = rng.Columns.Count Then
Print #1, cellValue
' found LastLine >> close the file
If Not cellValue = "" Then
Close #1
End If
Else
Print #1, cellValue,
End If
Next j
Next i
End Sub
I have a string compressed into one cell. I need to separate each part of the string into their own cell, while copying the data from the same row.
Here is my example data:
A | B
Row1 ABC ABD ABE ABF | CODE1
Row2 BCA DBA EBA FBA | CODE2
Row3 TEA BEF | CODE3
The result would be:
A B
ABC CODE1
ABD CODE1
ABE CODE1
ABF CODE1
BCA CODE2
DBA CODE2
EBA CODE2
FBA CODE2
TEA CODE3
BEF CODE3
I have about 2000 rows and would literally take 30 years to use the text to column function for this. So I am trying to write a vba macro. I think I am making this harder than it needs to be. Any thoughts or pushes in the right direction would be appreciated. Thanks in advance for any help.
This will work, (but it's mighty inefficient unless you do it in an array... nevertheless for only 2000 rows, you won't even notice the lag)
Function SplitThis(Str as String, Delimiter as String, SerialNumber as Long) As String
SplitThis = Split(Str, Delimiter)(SerialNumber - 1)
End Function
Use it as
= SPLITTHIS("ABC EFG HIJ", " ", 2)
' The result will be ...
"EFG"
You will still need to put in a whole lot of extra error checking, etc. if you need to use it for a distributed application, as the users might put in values greater than the number of 'split elements' or get delimiters wrong, etc.
I like iterating over cells for problems like this post.
' code resides on input sheet
Sub ParseData()
Dim wksOut As Worksheet
Dim iRowOut As Integer
Dim iRow As Integer
Dim asData() As String
Dim i As Integer
Dim s As String
Set wksOut = Worksheets("Sheet2")
iRowOut = 1
For iRow = 1 To UsedRange.Rows.Count
asData = Split(Trim(Cells(iRow, 1)), " ")
For i = 0 To UBound(asData)
s = Trim(asData(i))
If Len(s) > 0 Then
wksOut.Cells(iRowOut, 1) = Cells(iRow, 2)
wksOut.Cells(iRowOut, 2) = s
iRowOut = iRowOut + 1
End If
Next i
Next iRow
MsgBox "done"
End Sub
Assuming your data is on the first sheet, this populates the second sheet with the formatted data. I also assume that the data is uniform, meaning there is the same type of data on every row until the data ends. I did not attempt the header line.
Public Sub FixIt()
Dim fromSheet, toSheet As Excel.Worksheet
Dim fromRow, toRow, k As Integer
Dim code As String
Set fromSheet = Me.Worksheets(1)
Set toSheet = Me.Worksheets(2)
' Ignore first row
fromRow = 2
toRow = 1
Dim outsideArr() As String
Dim insideArr() As String
Do While Trim(fromSheet.Cells(fromRow, 1)) <> ""
' Split on the pipe
outsideArr = Split(fromSheet.Cells(fromRow, 1), "|")
' Split left of pipe, trimmed, on space
insideArr = Split(Trim(outsideArr(0)), " ")
' Save the code
code = Trim(outsideArr(UBound(outsideArr)))
' Skip first element of inside array
For k = 1 To UBound(insideArr)
toSheet.Cells(toRow, 1).Value = insideArr(k)
toSheet.Cells(toRow, 2).Value = code
toRow = toRow + 1
Next k
fromRow = fromRow + 1
Loop
End Sub
Let me try as well using Dictionary :)
Sub Test()
Dim r As Range, c As Range
Dim ws As Worksheet
Dim k, lrow As Long, i As Long
Set ws = Sheet1 '~~> change to suit, everything else as is
Set r = ws.Range("B1", ws.Range("B" & ws.Rows.Count).End(xlUp))
With CreateObject("Scripting.Dictionary")
For Each c In r
If Not .Exists(c.Value) Then
.Add c.Value, Split(Trim(c.Offset(0, -1).Value))
End If
Next
ws.Range("A:B").ClearContents
For Each k In .Keys
lrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
If lrow = 1 Then i = 0 Else i = 1
ws.Range("A" & lrow).Offset(i, 0) _
.Resize(UBound(.Item(k)) + 1).Value = Application.Transpose(.Item(k))
ws.Range("A" & lrow).Offset(i, 1).Resize(UBound(.Item(k)) + 1).Value = k
Next
End With
End Sub
Above code loads all items in Dictionary and then return it in the same Range. HTH.
Here is an approach using a User Defined Type, Collection and arrays. I've been using this lately and thought it might apply. It does make writing the code easier, once you get used to it.
The user defined type is set in a class module. I called the type "CodeData" and gave it two properties -- Code and Data
I assumed your data was in columns A & B starting with row 1; and I put the results on the same worksheet but in columns D & E. This can be easily changed, and put on a different worksheet if that's preferable.
First, enter the following code into a Class Module which you have renamed "CodeData"
Option Explicit
Private pData As String
Private pCode As String
Property Get Data() As String
Data = pData
End Property
Property Let Data(Value As String)
pData = Value
End Property
Property Get Code() As String
Code = pCode
End Property
Property Let Code(Value As String)
pCode = Value
End Property
Then put the following code into a Regular module:
Option Explicit
Sub ParseCodesAndData()
Dim cCodeData As CodeData
Dim colCodeData As Collection
Dim vSrc As Variant, vRes() As Variant
Dim V As Variant
Dim rRes As Range
Dim I As Long, J As Long
'Results start here. But could be on another sheet
Set rRes = Range("D1:E1")
'Get Source Data
vSrc = Range("A1", Cells(Rows.Count, "B").End(xlUp))
'Collect the data
Set colCodeData = New Collection
For I = 1 To UBound(vSrc, 1)
V = Split(vSrc(I, 1), " ")
For J = 0 To UBound(V)
Set cCodeData = New CodeData
cCodeData.Code = Trim(vSrc(I, 2))
cCodeData.Data = Trim(V(J))
colCodeData.Add cCodeData
Next J
Next I
'Write results to array
ReDim vRes(1 To colCodeData.Count, 1 To 2)
For I = 1 To UBound(vRes)
Set cCodeData = colCodeData(I)
vRes(I, 1) = cCodeData.Data
vRes(I, 2) = cCodeData.Code
Next I
'Write array to worksheet
Application.ScreenUpdating = False
rRes.EntireColumn.Clear
rRes.Resize(rowsize:=UBound(vRes, 1)) = vRes
Application.ScreenUpdating = True
End Sub
Here is the solution I devised with help from above. Thanks for the responses!
Sub Splt()
Dim LR As Long, i As Long
Dim X As Variant
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
Columns("A").Insert
For i = LR To 1 Step -1
With Range("B" & i)
If InStr(.Value, " ") = 0 Then
.Offset(, -1).Value = .Value
Else
X = Split(.Value, " ")
.Offset(1).Resize(UBound(X)).EntireRow.Insert
.Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End If
End With
Next i
Columns("B").Delete
LR = Range("A" & Rows.Count).End(xlUp).Row
With Range("B1:C" & LR)
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
On Error GoTo 0
.Value = .Value
End With
Application.ScreenUpdating = True
End Sub
I'm trying to copy a large number of lines (20k to 65k) into new workbooks, and for some reason, assigning the value of the range I'm copying uses more memory than using the copy/paste buffer, which doesn't make any sense to me, unless I'm somehow doing this wrong.
This is the original code:
Public Const FIRSTSHEETTAB As String = "Sheet1"
' <snip>
Dim last_row As Long
Dim num_files As Long
Dim ps_rng As Range
' <snip>
Dim i As Long
Dim new_book As Workbook
Dim start_row As Long
Dim end_row
start_row = 2
For i = 1 To num_files
Set new_book = Workbooks.Add
end_row = start_row + max_lines - 1
If end_row > last_row Then
end_row = last_row
End If
With new_book
.Windows(1).Caption = "PS Upload " & i
With .Worksheets(FIRSTSHEETTAB)
.Range("1:1").Value2 = ps_rng.Range("1:1").Value2
.Range("2:" & max_lines).Value2 = ps_rng.Range(CStr(start_row) & ":" & CStr(end_row)).Value2
End With
End With
start_row = end_row + 1
Next i
And what I had to do to get this working was change .Range("2:" & max_lines).Value2 = ps_rng.Range(CStr(start_row) & ":" & CStr(end_row)).Value2 to the following:
ps_rng.Range(CStr(start_row) & ":" & CStr(end_row)).Copy
.Range("2:" & max_lines).PasteSpecial
And I don't understand why this works where as the former code runs out of memory. I'd much rather not have to overwrite whatever is in the copy/paste buffer if I can help it.
What's causing just the simple assignment to run out of memory?
When you use Copy, Excel is smart enough only to copy the used part of the Copy range.
Eg. see below: granted this is looking at the "Text" version of what's on the clipboard, but that's pretty much what you're getting when you PasteSpecial
Sub Tester()
ActiveSheet.Cells.ClearContents
ActiveSheet.UsedRange 'reset sheet
CheckCopy '>> 1
ActiveSheet.Range("A1:J1").Value = "x"
CheckCopy '>> 10
ActiveSheet.Range("XFD1").Value = "x"
CheckCopy '>> 16384
ActiveSheet.Range("XFD1").ClearContents
CheckCopy '>> 16384
ActiveSheet.UsedRange 'reset sheet
CheckCopy '>> 10
End Sub
Sub CheckCopy()
Dim d As New DataObject, s As String
ActiveSheet.Rows(1).Copy
d.GetFromClipboard
s = d.GetText
Debug.Print "#Cols: " & IIf(Len(s) = 0, 0, UBound(Split(s, vbTab)) + 1)
End Sub
You don't get this optimization when you directly assign Value between two large ranges.
Because you are assigning the value of 16.384 x 65.000 = 1.064.960.000 cells simultaneously and this is too much for Excel to cope with.
A better approach would be to restrict the desired range to copy using the last column that does have values. I do not recommend utilizing the UsedRange property because it does give some unwanted results sometimes when a cell far away was edited sometime ago.
Below there is a code example:
Public Const FIRSTSHEETTAB As String = "Sheet1"
' <snip>
Dim last_row As Long
Dim num_files As Long
Dim ps_rng As Range
' <snip>
Dim i As Long
Dim new_book As Workbook
Dim start_row As Long
Dim end_row
start_row = 2
'Obtaining last column of the desired range
lastColumn = ps_rng.Cells(1, ps_rng.Columns.Count).End(xlToLeft).Column
For i = 1 To num_files
Set new_book = Workbooks.Add
end_row = start_row + max_lines - 1
If end_row > last_row Then
end_row = last_row
End If
With new_book
.Windows(1).Caption = "PS Upload " & i
With .Worksheets(FIRSTSHEETTAB)
.Range(.Cells(1, 1), .Cells(1, lastColumn)).Value2 = ps_rng.Range(ps_rng.Cells(1, 1), ps_rng.Cells(1, lastColumn)).Value2
.Range(.Cells(2, 1), .Cells(max_lines, lastColumn)).Value2 = ps_rng.Range(ps_rng.Cells(start_row, 1), ps_rng.Cells(end_row, lastColumn)).Value2
End With
End With
start_row = end_row + 1
Next i
I Have a Red Lion Data station that records temperatures from about 25 ovens and the data is stored on a network in CSV files. I would like to import this data into an Excel file once every two minutes, but only import the changes after the initial import. After the import, the VBA must release the CSV file for the 2 minutes so that it can be updated by the data station. I have searched the web, this site and the closest thing I have found is the following code. This code looks for changes but it does not import the file. any help would be appreciated.
Dim NextTime As Date
Function LastModTime(FileSpec As String) As Date
'Returns the date-time the file specified by FileSpec (path string) was last modified
Dim fs, f, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(FileSpec)
LastModTime = f.DateLastModified
End Function
Sub Check4Changes()
'Checks the file FilePath for changes every 60 seconds
'If file has changed, pops up a message box. Stores the
'last modified time in cell M1 of Sheet1
ChDir "Q:\Manufacturing\Equipment\DispatchLogs\logs\7-DES"
Const FilePath As String = "Q:\Manufacturing\Equipment\DispatchLogs\logs\7-DES\*.csv"
Dim LastMod As Date
On Error GoTo ReSchedule
LastMod = LastModTime(FilePath)
With Worksheets("Sheet1").Range("C1")
If IsEmpty(.Value) Then
.Value = LastMod
GoTo ReSchedule
ElseIf .Value < LastMod Then
.Value = LastMod
MsgBox FilePath & " updated.", vbInformation, "Check4Changes"
End If
End With
ReSchedule:
'Reschedule this same routine to run in one minute.
NextTime = Now + 2 / 1440
Application.StatusBar = "Next check at " & NextTime
Application.OnTime NextTime, "Check4Changes"
End Sub
Sub CancelChecking()
Application.OnTime NextTime, "Check4Changes", Schedule:=False
Application.StatusBar = False
End Sub
I have written some code which will give you the basic idea
Sub Main()
Dim Wbk_CSV As Excel.Workbook
Dim Excel_Wbk As Excel.Workbook
Dim Var_WholeCSVData As Variant
Dim Var_ExcelData As Variant
Dim Var_ToUpdate As Variant
Dim NumOfRows As Long
Dim Last_Row As Long
Set Wbk_CSV = Workbooks.Open("PathWithFileName")
Wbk_CSV.Sheets(1).Activate
Last_Row = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
'Taking whole data in a variant
'Change the range as per the data in csv file
Var_WholeCSVData = Wbk_CSV.Sheets(1).Range("A2:D" & Last_Row).Value 'Considering first row as header row and there are 4 columns
'After taking whole data in varinat close csv file without saving
Wbk_CSV.Close savechanges:=False
Set Wbk_CSV = Nothing
'Now open excel file in which data will be updated
Set Excel_Wbk = Workbooks.Open("PathWithFileName")
Excel_Wbk.Sheets(1).Activate
Last_Row = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
Var_ExcelData = Excel_Wbk.Sheets(1).Range("A2:D" & Last_Row).Value 'Considering first row as header row
NumOfRows = 0
'This function will return count of updated rows and data to update
Var_ToUpdate = Delete_Duplicates(Var_WholeCSVData, Var_ExcelData, NumOfRows)
Excel_Wbk.Sheets(1).Activate
'paste data
If NumOfRows > 0 Then
ActiveSheet.Range("A" & Last_Row + 1 & ":D" & Last_Row + NumOfRows).Value = Var_ToUpdate
End If
Excel_Wbk.Close savechanges:=True
Set Excel_Wbk = Nothing
'result
MsgBox ("Number of rows imported: " & NumOfRows)
End Sub
Function Delete_Duplicates(Var_FromCSV As Variant, Var_FromExcel As Variant, ByRef NumberOfRowToupdate As Long) As Variant
'using dictinpary objects
Dim dict_Duplicates As Object
Dim i_AddToDict, i, j As Long
Dim Str_value As String
Dim Var_Temp As Variant
Dim lng_temp As Long
Set dict_Duplicates = CreateObject("Scripting.Dictionary")
ReDim Var_Temp(1 To UBound(Var_FromCSV, 1), 1 To UBound(Var_FromCSV, 2))
'Add excel data to dict. by concatenating
'All unique values will be added
For i_AddToDict = 1 To UBound(Var_FromCSV)
Str_value = CStr(Var_FromExcel(i_AddToDict, 1) & Var_FromExcel(i_AddToDict, 2) & Var_FromExcel(i_AddToDict, 3) & Var_FromExcel(i_AddToDict, 4))
If dict_Duplicates.exists(Str_value) Then
'do nothing
Else
dict_Duplicates.Add Str_value, 1
End If
Next i_AddToDict
'looking for values which are not available in excel file
For i = 1 To UBound(Var_FromCSV)
Str_value = CStr(Var_FromCSV(i_AddToDict, 1) & Var_FromCSV(i_AddToDict, 2) & Var_FromCSV(i_AddToDict, 3) & Var_FromCSV(i_AddToDict, 4))
If dict_Duplicates.exists(Str_value) Then
'do nothing
Else
'storing values in a variant
For j = 1 To 4
Var_Temp(lng_temp, j) = Var_FromCSV(i, j)
Next j
lng_temp = lng_temp + 1
dict_Duplicates.Add Str_value, 1
End If
Next i
NumberOfRowToupdate = lng_temp - 1
Delete_Duplicates = Var_Temp
End Function
enter code hereI have my following code a bit short in the process of working on it, so I am trying to get text from a .txt file to be displayed in a cell on Excel, the code will be
Sub citi()
Dim c As Range
Open "C:\Users\alvaradod\Desktop\citi macro\Import File.txt" For Input As #1
R = 0
Dim i As Range
Dim num As Integer
Dim arrData() As String
the_value = Sheets("Prog").Range("A1")
Do Until EOF(1)
Line Input #1, Data
If Not Left(Data, 1) = "" Then
'import this row
R = R + 1
Cells(R, 1).Value = Data
'Mid(the_value, 3, 5)
'Left(Data, Len(Data) - 3)).Value
End If
Loop
For Each i In Range("A1")
i.Select
ActiveCell.Rows("1:1").Mid(Data(i), 49, 5).Select
'ActiveCell.Rows("1:1").EntireRow.Select
Selection.Copy
Sheets("Import").Range("A1").End(xlUp).Offset(num, 0).PasteSpecial
ActiveCell.Rows.Delete
num = num + 1
Next i
End Sub
" LINE 11 WILL PAST THE TEXT FROM LINE ONE ON .TXT FILE TO EXCEL, AFTER THIS FUNCTION I NEED TO TRIM THIS SAME TEXT IN THE EXCEL SHEET TO SHOW THE FIRST 5 CHARACTERS"
Your question isn't very clear, but perhaps something like this?
Sub citi()
Dim oFSO As Object
Dim arrData() As String
Dim arrImport1(1 To 65000) As String
Dim arrImport2(1 To 65000) As String
Dim i As Long, j As Long
Set oFSO = CreateObject("Scripting.FileSystemObject")
arrData = Split(oFSO.OpenTextFile("C:\Test\test.txt").ReadAll, vbCrLf)
For i = LBound(arrData) To UBound(arrData)
If Len(arrData(i)) > 0 Then
j = j + 1
arrImport1(j) = Mid(arrData(i), 3, 5)
arrImport2(j) = Mid(arrData(i), 49, 5)
End If
Next i
If j > 0 Then
Sheets("Sheet1").Range("A1").Resize(j).Value = Application.Transpose(arrImport1)
Sheets("Sheet2").Range("A1").Resize(j).Value = Application.Transpose(arrImport2)
End If
Set oFSO = Nothing
Erase arrData
Erase arrImport
End Sub