Steps I need to do:
Open all necessary files(which are from the same folder) in Excel
For the first file, copy from row 6 to bottom of table. For second and subsequent files, copy from row 7 to bottom of table (Note that each file has different number of table rows). (Reasoning is that rows 1-5 are irrelevant, row 6 has heading, and I only want the heading to appear once in the table)
Paste into main excelsheet, but without overlapping previous rows
Separate main excelsheet by commas (text to column)
Close all files other than main excelsheet
Tried to google the various steps, but each step's code does not work well with one another, resulting in numerous errors, so I gave up and tried to record macro, but I did not get a "for" loop.
I've just tested the code below
Sub Read_Texts()
'Variable Declaration
Dim sFilePath As String
Dim sFileName As String
'Specify File Path
sFilePath = "C:\Users\use\Desktop\New folder"
'Check for back slash
If Right(sFilePath, 1) <> "\" Then
sFilePath = sFilePath & "\"
End If
sFileName = Dir(sFilePath & "*.txt")
Do While Len(sFileName) > 0
If Right(sFileName, 3) = "txt" Then
'Display file name in immediate window
Dim hf As Integer: hf = FreeFile
Dim lines() As String, i As Long
Open sFileName For Input As #hf
lines = Split(Input$(LOF(hf), #hf), vbNewLine)
Close #hf
If sFileName = "file1.txt" Then
For i = 5 To UBound(lines)
Debug.Print "File 1 Line"; i; "="; lines(i)
Next
Else
For i = 6 To UBound(lines)
Debug.Print "File 1 Line"; i; "="; lines(i)
Next
End If
End If
'Set the fileName to the next available file
sFileName = Dir
Loop
End Sub
Change C:\Users\use\Desktop\New folder according to your folder path, and here you can do whatever with the returned lines Debug.Print "File 1 Line"; i; "="; lines(i)
Related
I'm using the VBA code below to export Excel rows to individual text file (file name is Column B)
Sub ExportTextFiles()
Dim i As Long
Dim LastDataRow As Long
Dim MyFile As String
Dim fnum
LastDataRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LastDataRow
'The next line uses the contents of column B on the same row to name it
MyFile = "C:\test\" & ActiveSheet.Range("B" & i).Value & ".txt"
fnum = FreeFile()
Open MyFile For Output As fnum
Print #fnum, Format(Range("A" & i))
Close fnum
Next i
End Sub
My problem is only 255 Characters of row exported in the text.
is there a workaround ?
For reasons that I have not been able to find clear documentation, when you use the Format function with no format defined, it will return only 255 characters.
I don't understand why you need to use the Format function in your Print statement, but if you remove it, the 255 character limitation seems to disappear.
The only thing I think you might have to worry about is the cell contents limitation of 32,767 characters.
I'm new in VBA. Before posting my question here,I have spent almost 3 days surfing Internet.
I have 300+ text files (text converted from PDF using OCR),from text file. I need to get all words that contain "alphabet" and "digits" (as example KT315A, KT-315-a, etc) along with source reference (txt file name).
What I need is
1.add "smart filter" that will copy only words that contains
"alphabets" and "digits"
paste copied data to column A
add reference file name to column B
I have found code below that can copy all data from text files into excel spreadsheet.
text files look like
"line from 252A-552A to ddddd, ,,, #,#,rrrr, 22 , ....kt3443 , fff,,,etc"
final result in xls should be
A | B
252A-552A | file1
kt3443 | file1
Option Explicit
Const sPath = "C:\outp\" 'remember end backslash
Const delim = "," 'comma delimited text file - EDIT
'Const delim = vbTab 'for TAB delimited text files
Sub ImportMultipleTextFiles()
Dim wb As Workbook
Dim sFile As String
Dim inputRow As Long
RefreshSheet
On Error Resume Next
sFile = Dir(sPath & "*.txt")
Do Until sFile = ""
inputRow = Sheets("Temp").Range("A" & Rows.Count).End(xlUp).Row + 1
'open the text file
'format=6 denotes a text file
Set wb = Workbooks.Open(Filename:=sPath & sFile, _
Format:=6, _
Delimiter:=delim)
'copy and paste
wb.Sheets(1).Range("A1").CurrentRegion.Copy _
Destination:=ThisWorkbook.Sheets("Temp").Range("A" & inputRow)
wb.Close SaveChanges:=False
'get next text file
sFile = Dir()
Loop
Set wb = Nothing
End Sub
Sub RefreshSheet()
'delete old sheet and add a new one
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = True
Worksheets.Add
ActiveSheet.Name = "Temp"
On Error GoTo 0
End Sub
thanks!
It's a little tough to tell exactly what constitutes a word from your example. It clearly can contain characters other than letters and numbers (eg the dash), but some of the items have dots preceding, so it cannot be defined as being delimited by a space.
I defined a "word" as a string that
Starts with a letter or digit and ends with a letter or digit
Contains both letters and digits
Might also contain any other non-space characters except a comma
To do this, I first replaced all the commas with spaces, and then applied an appropriate regular expression. However, this might accept undesired strings, so you might need to be more specific in defining exactly what is a word.
Also, instead of reading the entire file into an Excel workbook, by using the FileSystemObject we can process one line at a time, without reading 300 files into Excel. The base folder is set, as you did, by a constant in the VBA code.
But there are other ways to do this.
Be sure to set the references for early binding as noted in the code:
Option Explicit
'Set References to:
' Microsoft Scripting Runtime
' Microsoft VBscript Regular Expressions 5.5
Sub SearchMultipleTextFiles()
Dim FSO As FileSystemObject
Dim TS As TextStream, FO As Folder, FI As File, FIs As Files
Dim RE As RegExp, MC As MatchCollection, M As Match
Dim WS As Worksheet, RW As Long
Const sPath As String = "C:\Users\Ron\Desktop"
Set FSO = New FileSystemObject
Set FO = FSO.GetFolder(sPath)
Set WS = ActiveSheet
WS.Columns.Clear
Set RE = New RegExp
With RE
.Global = True
.Pattern = "(?:\d(?=\S*[a-z])|[a-z](?=\S*\d))+\S*[a-z\d]"
.IgnoreCase = True
End With
For Each FI In FO.Files
If FI.Name Like "*.txt" Then
Set TS = FI.OpenAsTextStream(ForReading)
Do Until TS.AtEndOfStream
'Change .ReadLine to .ReadAll *might* make this run faster
' but would need to be tested.
Set MC = RE.Execute(Replace(TS.ReadLine, ",", " "))
If MC.Count > 0 Then
For Each M In MC
RW = RW + 1
WS.Cells(RW, 1) = M
WS.Cells(RW, 2) = FI.Name
Next M
End If
Loop
End If
Next FI
End Sub
I am currently trying to create a spreadsheet which keeps track of how many files have been quality checked against those that haven't and then displays the amount left to be checked as a percentage.
Currently on open the spreadsheet pulls the details from a checked folder and a work to be checked folder as follows:-
Private Sub pdf_loading()
Range("M5").Clear
Dim FolderPath As String, path As String, count As Integer
FolderPath = "C:\path to folder\"
' looks in spercific folder
path = FolderPath & "*.pdf"
' for file type this time it is pdf files, though if you change this is could be word files, or psd's
Filename = Dir(path)
Do While Filename <> ""
' checks for filename <less than or >greater than "filename" as "" is empty does not look for spercific file
count = count + 1
' counts amount of pdf files, add 1 to the last known number
Filename = Dir()
' contiunes count until it reaches the end of the directory
Loop
Range("M5").Value = count
' puts final count value in cell
For Each Cell In [M:M]
If Cell.Value = "0" Then
Cell.ClearContents
ElseIf Range("M5").Value >= 1 Then
End If
Next Cell
End Sub
Then for the checked folder:-
Private Sub checked_loading()
Range("M6").Clear
Dim FolderPath As String, path As String, count As Integer
FolderPath = "C:\path to folder\"
path = FolderPath & "*.pdf"
Filename = Dir(path)
Do While Filename <> ""
count = count + 1
Filename = Dir()
Loop
Range("M6").Value = count
For Each Cell In [M:M]
If Cell.Value = "0" Then
Cell.ClearContents
ElseIf Range("M5").Value >= 1 Then
End If
Next Cell
End Sub
This works fine, though currently the formula I have tried to generate the percentage is as follows:-
=IF(M5=M6,"50%",IF(M5=0,"100%",IF(M6=0,"0%",SUM(M5*M6/100*1))))
This brings back incorrect results like 144.00% when the files to be check result is 9 and the files checked result is 16.
I would prefer to have the percentage calculation to be in vba so that end users could not accidentally delete the underlying formula.
Any help on this issue or if there is a more efficient code structure would be most appreciate.
Not to worry I have found a solution which works a treat. The above code now looks like this for the work to be checked:-
Private Sub pdf_loading()
Range("K5:L6").ClearContents
Range("M5").ClearContents
' Clear cell contents on open
Dim FolderPath As String, path As String, count As Integer
FolderPath = "C:\filepath\folder\"
' looks in spercific folder
path = FolderPath & "*.pdf"
' for file type this time it is pdf files, though if you change this is could be word files, or psd's
Filename = Dir(path)
Do While Filename <> ""
' checks for filename <less than or >greater than "filename" as "" is empty does not look for spercific file
count = count + 1
' counts amount of pdf files, add 1 to the last known number
Filename = Dir()
' contiunes count until it reaches the end of the directory
Loop
Range("M5").Value = count
' puts final count value in cell
End Sub
and the work checked folder is now like this:-
Private Sub checked_loading()
Range("M6").ClearContents
Dim FolderPath As String, path As String, count As Integer
FolderPath = "C:\filepath\folder\"
path = FolderPath & "*.pdf"
Filename = Dir(path)
Do While Filename <> ""
count = count + 1
Filename = Dir()
Loop
Range("M6").Value = count
Range("N5").Formula = "=Sum(M5,M6)"
Range("K5").Formula = "=SUM(M6/N5*1)"
' adds formulas to selected cells to give percentage
End Sub
I have an existing xls file which creates a CONTENTS file based on the files in a directory. For example, if a directory contains file.pdf and file.txt, it will create a file with contents
file.pdf
file.txt
with each file separated by a line break.
What I would like to do is that I want the contents to contain
file.pdf bundle:ORIGINAL
file.txt bundle:TEXT
file.pdf and bundle:ORIGINAL is separated by a tab character. The directory will contain these 2 filetypes, 1 pdf and 1 text file. So basically, what I want is that for every pdf file, it should be followed by bundle:ORIGINAL text while if its a text file, it should be followed by bundle:TEXT.
The original code is below:
For i = 2 To lRows
If Trim(Cells(i, 1).Value) = "" Then Exit For
' create the CONTENTS file
FileList = GetFileList(oDirectory & "\" & Trim(Cells(i, lCols).Value) & "\")
cFileNum = FreeFile
ContentsPath = oDirectory & "\" & Trim(Cells(i, lCols).Value) & "\" & "contents"
Open ContentsPath For Output As #cFileNum
For k = 1 To UBound(FileList)
If (FileList(k) <> "contents" And FileList(k) <> "dublin_core.xml") Then
Print #cFileNum, FileList(k)
End If
Next k
Close #cFileNum
EDIT
This is the Function GetFileList
Function GetFileList(FileSpec As String) As Variant
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound
' Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
' Error handler
NoFilesFound:
GetFileList = False
End Function
Please note that I am obviously not the author of this code, I just downloaded this excel file (the site no longer exists) a long time ago and I just need to tweak this for my own use.
Thanks in advance.
Something like this should do it:
'...
If (FileList(k) <> "contents" And FileList(k) <> "dublin_core.xml") Then
Print #cFileNum, FileList(k) & vbTab & GetType(Cstr(FileList(k)))
End If
'...
Function:
Function GetType(fName as string)
Dim rv As String
Select Case Right(Ucase(fName),3)
Case "TXT": rv = "bundle:TEXT"
Case "PDF": rv = "bundle:ORIGINAL"
End Select
GetType = rv
End Function
An Excel sheet exists with a list of machine names in Column A in Sheet1.
A text file exists with a list of machines that are decommissioned.
I need to mark all the decommissioned machines as "DECOM" in the Excel sheet under column B on the same Sheet (Sheet1).
Here is what I have so far.
Sub ImportTextFileContents()
Dim strg As Variant
Dim EntireLine As String
FName = Application.GetOpenFilename("Text Files (*.txt), *.txt", , "Choose File to Import")
Open FName For Input Access Read As #1
i = 1
While Not EOF(1)
Line Input #1, EntireLine
strg = EntireLine
If (Sheets("Sheet1").Range("A").Value = strg) Then
Sheets("Sheet1").Range("B" & i).Value = "DECOM"
End If
i = i + 1
Wend
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #1
End Sub
Try something like this:
Sub ImportTextFileContents()
Dim strg As Variant
Dim EntireLine As String
Dim DecomMachines() as String
Dim rngExcel as Range
Dim cell as Range
FName = Application.GetOpenFilename("Text Files (*.txt), *.txt", , "Choose File to Import")
Open FName For Input Access Read As #1
'Create an array to contain the list of Decommissioned machines from the TXT file
i = 1
While Not EOF(1)
Line Input #1, EntireLine
strg = EntireLine
ReDim Preserve DecomMachines(0 to i-1)
DecomMachines(i-1) = strg
i = i + 1
Wend
'Set the range variable over which we need to iterate:
Set rngExcel = Sheets("Sheet1").Range("A1",Range("A1").End(xlDown).Address) '<-- modify as needed
For each cell in rngExcel
'Check to see if this cell.value exists in the array we built, above:
If Not IsError(Application.Match(Cstr(cell.Value),DecomMachines,False)) Then
'if the name exists in the DecomMachines array, then we need to mark it as decommissioned.
cell.Offset(0,1).Value = "DECOM"
Else:
'it doesnot exist in the TXT file, so ignore it
End If
Next
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #1
End Sub
This creates an array that contains all of the machines identified in the TXT file, and then iterates over the range of cells in Column A, testing to see if each cell value exists in the array. If it does exist, then we know to mark it as decommissioned in column B (cell.Offset(0,1)) and if it does not exist, we just move on to the next cell in column A.