I have VBA code for opening a text file and writing the lines into a sheet.
I now want to add a message box that would indicate if this file has been edited or not.
My code for opening the file is as follows:
Private Sub CommandButton1_Click() ' OPEN THE HISTORY FILE AND IMPORT INTO THE FULL HISTORY FILE SHEET
Dim Wsheet As Worksheet, WRange As Range
Set Wsheet = Sheets("Full History File")
Set WRange = Wsheet.Range("A1")
If IsEmpty(WRange.Value) = False Then
EmptyCheck
UserForm_Activate
ImportHistoryFile
Else
ImportHistoryFile
End If
End Sub
Then:
Sub ImportHistoryFile()
Dim Fname As Variant, Text As String, Wsheet As Worksheet, WRange As Range, Cell As Integer
Dim openPos As Integer
Dim closePos As Integer
Set Wsheet = Sheets("Full History File")
Set WRange = Wsheet.Range("A1")
Fname = Application.GetOpenFilename("History Files (*.txt), *.txt") 'OPEN THE FILE EXPLORER TO SELECT THE HISTORY FILE
If Fname = False Then
Exit Sub
Else
Open Fname For Input As #1
Cell = 0
Do Until EOF(1)
Line Input #1, Text
WRange.Offset(Cell, 0) = Text
Cell = Cell + 1
Loop
Close #1
MsgBox "History file successfully opened " & Dir(Fname)
openPos = InStr(1, Dir(Fname), "-") + 1
closePos = InStr(openPos, Dir(Fname), ".")
Frame1.Visible = True
Frame1.Caption = Mid(Dir(Fname), openPos, closePos - openPos) & " History File Information and Summary"
CommandButton2.Visible = True
Label3.Visible = True
Label3.Caption = Dir(Fname)
End If
End Sub
Any help on verifying the file integity when importing would be reatly appreciated.
Related
I want to open a text file from my directory to find emails from a text.
I use this code:
Public Sub makeEmailList()
Fname = Application.GetOpenFilename(MultiSelect:=True)
If Not IsArray(Fname) Then MsgBox "No File Selected", vbMsgBoxRtlReading, "": Exit Sub
Dim wbkExport As Workbook
Set wbkExport = Application.Workbooks.Add
wbkExport.Worksheets(1).Cells(1, 1).Select
Selection = "EMail"
r = 1
For K = LBound(Fname) To UBound(Fname)
If Right(Fname(K), 4) = ".txt" Then
Open Fname(K) For Input Access Read As #1
While Not EOF(1)
Line Input #1, WholeLine
If InStr(WholeLine, "#") > 0 Then
S = InStr(WholeLine, "<th>")
e = InStr(WholeLine, "</th>")
r = r + 1
wbkExport.Worksheets(1).Cells(r, "A") = Mid(WholeLine, S + 4, e - S - 4)
End If
Wend
End If
Next K
Close #1
End Sub
when the name of all folders and sub folders that contains the text file, are English, everything is ok. but when I choose a file from a path that has a folder that it's name contains Persian characters (just this two characters: "ی" and "ک") it returns Error 76: path not Found.
In Persian we type "ی" as ChrW(1740) but vba uses arabic "ي" with ChrW(1610) instead and we type ChrW(1705) for "ک" but VBA Uses ChrW(1603). this is the reason.
The error occurs here:
Open Fname(K) For Input Access Read As #1
I used the replace function, above this line, to change characters but it did'nt work.
Fname(K) = Replace(Replace(Fname(K), ChrW(1610), ChrW(1740)), ChrW(1603), ChrW(1705))
I checked the windows language and location setting on windows And Language setting in excel options, and it is ok.
thank you for your help.
Open File When Non-English Letters in Path
Instead of the Open statement, use the OpenTextFile method of the FileSystemObject object.
Public Sub MakeEmailList()
' Needs a reference to VBE->Tools->References->Microsoft Scripting Runtime
Dim fPaths As Variant: fPaths = Application.GetOpenFilename(MultiSelect:=True)
If Not IsArray(fPaths) Then MsgBox "No File Selected", vbMsgBoxRtlReading, "": Exit Sub
Dim wbkExport As Workbook: Set wbkExport = Workbooks.Add(xlWBATWorksheet)
Dim wsExport As Worksheet: Set wsExport = wbkExport.Worksheets(1)
wsExport.Range("A1").Value = "EMail"
Dim r As Long: r = 1
' Early binding needs a reference and has IntelliSense to easily learn.
Dim fso As Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
' Or: Late binding needs no reference; no IntelliSense though.
'Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
Dim fsoTextStream As Scripting.TextStream ' early binding...
'Dim fsoTextStream As Object ' ... or late binding
Dim fPath As String
Dim fExtension As String
Dim WholeLine As String
Dim sPos As Long
Dim ePos As Long
Dim n As Long
For n = LBound(fPaths) To UBound(fPaths)
fPath = fPaths(n)
'Debug.Print "Path: " & fPath
fExtension = fso.GetExtensionName(fPath)
If StrComp(fExtension, "txt", vbTextCompare) = 0 Then
Set fsoTextStream = fso.OpenTextFile(fPaths(n), ForReading)
Do While Not fsoTextStream.AtEndOfStream
'DoEvents
WholeLine = fsoTextStream.ReadLine
'Debug.Print "Line: " & WholeLine
If InStr(WholeLine, "#") > 0 Then
sPos = InStr(WholeLine, "<th>")
ePos = InStr(WholeLine, "</th>")
r = r + 1
wsExport.Cells(r, "A") = Mid(WholeLine, sPos + 4, ePos - sPos - 4)
End If
Loop
fsoTextStream.Close
End If
Next n
End Sub
before people say this question has been asked before, trust me I have read most entries but I just can't get my head around it. I have a fold of about 550 CSV files, each about 25mb. I'm trying to automatically remove the unnecessary columns to bring the file size down to 2mb, so that then I can analyse them with another language ( that I'm more comfortable with )
I found this code on the net :
Option Explicit
Sub Delete_First_Last_Columns_From_CSV_Files()
Dim source_folder_name As String
source_folder_name = "C:\Users\Domenic\Desktop\" 'change the path to the source folder accordingly
If Right(source_folder_name, 1) <> "\" Then
source_folder_name = source_folder_name & "\"
End If
If Len(source_folder_name) = 0 Then
MsgBox "The path to the source folder is invalid!", vbExclamation, "Invalid Path"
Exit Sub
End If
Application.ScreenUpdating = False
Dim columns_to_delete As Variant
columns_to_delete = Array("First", "Last") 'change and/or add column headers as desired
Dim current_filename As String
current_filename = Dir(source_folder_name & "*.csv", vbNormal)
Dim file_count As Long
While Len(current_filename) > 0
file_count = file_count + 1
Delete_Columns_from_CSV_File source_folder_name & current_filename, columns_to_delete
current_filename = Dir
Wend
Application.ScreenUpdating = True
MsgBox "Number of files processed: " & file_count, vbInformation, "Files Processed"
End Sub
Private Sub Delete_Columns_from_CSV_File(ByVal source_filename As String, ByVal columns_to_delete As Variant)
Dim source_workbook As Workbook
Set source_workbook = Workbooks.Open(Filename:=source_filename)
Dim source_worksheet As Worksheet
Set source_worksheet = source_workbook.Worksheets(1)
Dim column_found As Range
Dim i As Long
For i = LBound(columns_to_delete) To UBound(columns_to_delete)
Set column_found = source_worksheet.Rows(1).Find(what:=columns_to_delete(i), LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
If Not column_found Is Nothing Then
column_found.EntireColumn.Delete
End If
Next i
source_workbook.Close SaveChanges:=True
End Sub
I paste this code through visual basic part of EXCEL to the current workbook, but it only runs the script on the current file and not the rest of the folder. How do I fix it so it runs on all files ?
I am trying to copy some data from one workbook to another, with checking certain cells content from 2 files. Below is my code:
Sub GetFileCopyData()
Dim Fname As String
Dim SrcWbk As Workbook
Dim DestWbk As Workbook
Dim miesiac() As Variant
Dim m_i, i, wiersz_nazw As Integer
Dim Msc, nazw As String
miesiac = Array(styczeń, luty, marzec, kwiecień, maj, czerwiec, lipiec, sierpień, wrzesień, październik, listopad, grudzień)
Set DestWbk = ThisWorkbook
Set SrcWbk = ActiveWorkbook
Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Select a File")
If Fname = "False" Then Exit Sub
Set SrcWbk = Workbooks.Open(Fname)
Set DestWbk = ActiveWorkbook
Msc = SrcWbk.Cells(2, 13).Text
m_i = szukaj(miesiac, Msc)
nazw = Cells(3, 4).Text
For i = 1 To 100 Step 1
If nazw Like "*" & SrcWbk.Cells(i, 24) & "*" Then
wiersz_nazw = i: Exit For
End If
Next
SrcWbk.Cells(wiersz_nazw, 2).Copy DestWbk.Cells(m_i + 7, 3)
End Sub
Function szukaj(ByRef lista As Variant, ByVal wartosc As String)
Dim found As Integer, foundi As Integer ' put only once
found = -1
For foundi = LBound(lista) To UBound(lista):
'If lista(foundi) = wartosc Then
If StrComp(lista(foundi), wartosc, vbTextCompare) = 0 Then
found = foundi: Exit For
End If
Next
szukaj = found
End Function
It gets runtime 438 error in this line:
Msc = SrcWbk.Cells(2, 13).Text
The script have to get text parameter from source workbook cell 2,13, then take number for this text from array. Then scrip has to get text parameter from destination work book cell 3,4 and search for it in source workbook. Then I can copy some data.
This covers most of the comments. I think it should work, but you might have to check the workbook/sheet names as I wasn't entirely clear in all cases.
And check I have the wiersz_nazw bit correct.
The original 438 error was caused because Cells needs a sheet parent, not a workbook parent.
Sub GetFileCopyData()
Dim Fname As String
Dim SrcWbk As Workbook
Dim DestWbk As Workbook
Dim miesiac() As Variant
Dim m_i As Variant, i As Long, wiersz_nazw As Variant
Dim Msc As String, nazw As String 'each one needs to be specified
miesiac = Array(styczen, luty, marzec, kwiecien, maj, czerwiec, lipiec, sierpien, wrzesien, pazdziernik, listopad, grudzien)
Set DestWbk = ThisWorkbook 'file containing code
Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Select a File")
If Fname = "False" Then Exit Sub
Set SrcWbk = Workbooks.Open(Fname)
Msc = SrcWbk.Worksheets(1).Cells(2, 13).Text
m_i = Application.Match(Msc, miesiac, 0)
If Not IsNumeric(m_i) Then m_i = -1
nazw = SrcWbk.Worksheets(1).Cells(3, 4).Text 'change workbook/sheet as necessary
wiersz_nazw = Application.Match("*" & nazw & "*", SrcWbk.Worksheets(1).Range("X1:X100"), 0)
If IsNumeric(wiersz_nazw) Then
SrcWbk.Worksheets(1).Cells(wiersz_nazw, 2).Copy DestWbk.Worksheets(1).Cells(m_i + 7, 3) 'change sheets as necessary
End If
End Sub
Here is what my Txt file looks like... this gets exported via an old but useful tool:
Here is the code I found on Internet:
Option explicit
Sub ReadInCommaDelimFile()
Dim rFirstCell As Range 'Points to the First Cell in the row currently being updated
Dim rCurrentCell As Range 'Points the the current cell in the row being updated
Dim sCSV As String 'File Name to Import
Dim iFileNo As Integer 'File Number for Text File operations
Dim sLine As String 'Variable to read a line of file into
Dim sValue As String 'Individual comma delimited value
'Prompt User for File to Import
sCSV = Application.GetOpenFilename("CSV Files, *.TXT", , "Select File to Import")
If sCSV = "False" Then Exit Sub
'Clear Existing Data
ThisWorkbook.Worksheets("IMPORT").Cells.Delete
'wsData.Cells.Delete 'Use this method if you set the vb-name of the sheet
'Set initial values for Range Pointers
Set rFirstCell = Range("A2")
Set rCurrentCell = rFirstCell
'Get an available file number
iFileNo = FreeFile
'Open your CSV file as a text file
Open sCSV For Input As #iFileNo
'Loop until reaching the end of the text file
Do Until EOF(iFileNo)
'Read in a line of text from the CSV file
Line Input #iFileNo, sLine
Do
sValue = ParseData(sLine, "','")
If sValue <> "" Then
rCurrentCell = sValue 'put value into cell
Set rCurrentCell = rCurrentCell.Offset(0, 1) 'move current cell one column right
End If
Loop Until sValue = ""
Set rFirstCell = rFirstCell.Offset(1, 0) 'move pointer down one row
Set rCurrentCell = rFirstCell 'set output pointer to next line
Loop
'Close the Text File
Close #iFileNo
End Sub
Private Function ParseData(sData As String, sDelim As String) As String
Dim iBreak As Integer
iBreak = InStr(1, sData, sDelim, vbTextCompare)
If iBreak = 0 Then
If sData = "" Then
ParseData = ""
Else
ParseData = sData
sData = ""
End If
Else
ParseData = Left(sData, iBreak - 1)
sData = Mid(sData, iBreak + 1)
End If
End Function
Here is my result:
No matter what I try, I always get stuck with the Quote mark and Commas.
Here is the working code:
Option Explicit
Sub ReadInCommaDelimFile()
Dim rFirstCell As Range 'Points to the First Cell in the row currently being updated
Dim rCurrentCell As Range 'Points the the current cell in the row being updated
Dim sCSV As String 'File Name to Import
Dim iFileNo As Integer 'File Number for Text File operations
Dim sLine As String 'Variable to read a line of file into
Dim sValue As String 'Individual comma delimited value
Dim sValue2 As String 'Individual comma delimited value
'Prompt User for File to Import
sCSV = Application.GetOpenFilename("CSV Files, *.TXT", , "Select File to Import")
If sCSV = "False" Then Exit Sub
'Clear Existing Data
ThisWorkbook.Worksheets("IMPORT").Cells.Delete
'wsData.Cells.Delete 'Use this method if you set the vb-name of the sheet
'Set initial values for Range Pointers
Set rFirstCell = Range("A2")
Set rCurrentCell = rFirstCell
'Get an available file number
iFileNo = FreeFile
'Open your CSV file as a text file
Open sCSV For Input As #iFileNo
'Loop until reaching the end of the text file
Do Until EOF(iFileNo)
'Read in a line of text from the CSV file
Line Input #iFileNo, sLine
Do
sValue = ParseData(sLine, ",")
If sValue <> "" Then
sValue2 = Left(sValue, Len(sValue) - 1)
sValue2 = Right(sValue2, Len(sValue2) - 1)
rCurrentCell = sValue2 'put value into cell
Set rCurrentCell = rCurrentCell.Offset(0, 1) 'move current cell one column right
End If
Loop Until sValue = ""
Set rFirstCell = rFirstCell.Offset(1, 0) 'move pointer down one row
Set rCurrentCell = rFirstCell 'set output pointer to next line
Loop
'Close the Text File
Close #iFileNo
End Sub
Private Function ParseData(sData As String, sDelim As String) As String
Dim iBreak As Integer
iBreak = InStr(1, sData, sDelim, vbTextCompare)
If iBreak = 0 Then
If sData = "" Then
ParseData = ""
Else
ParseData = sData
sData = ""
End If
Else
ParseData = Left(sData, iBreak - 1)
sData = Mid(sData, iBreak + 1)
End If
End Function
Try adding this above "sValue = ParseData(sLine, "','")" to remove the single quotes
sLine = Replace(sLine, "'", "")
Your last code iteration indicates that your CSV file is saved as a *.txt file.
If that is really the case, you could open it using the Workbooks.OpenText method which would allow you to properly parse the data, including handling the singlequote text qualifier character.
This will not create a table as does the QueryTables method.
Then copy the data from this newly opened workbook to your IMPORT worksheet in your present workbook.
For example:
Option Explicit
Sub ReadInCommaDelimFile()
Dim sCSV
Dim WB As Workbook, dataWS As Worksheet
sCSV = Application.GetOpenFilename("CSV Files (*.txt),*.txt", , "Select File to Import")
If sCSV = False Then Exit Sub
ThisWorkbook.Worksheets("IMPORT").Cells.Clear
Application.ScreenUpdating = False
Workbooks.OpenText Filename:=sCSV, _
textqualifier:=xlTextQualifierSingleQuote, _
consecutivedelimiter:=True, _
Tab:=False, _
semicolon:=False, _
comma:=True, _
Space:=False, _
other:=False
Set WB = ActiveWorkbook
Set dataWS = WB.Worksheets(1)
dataWS.UsedRange.Copy ThisWorkbook.Worksheets("IMPORT").Range("A2")
WB.Close savechanges:=False
End Sub
The script below is incomplete because I would like the destination file to be opened from a folder that the user has previously chosen. The file name is set but the user can choose which folder the file should reside in.
Essentially, the objective of this script is to create a pipe delimited file from an excel sheet residing in this file. Subsequently the user chooses the folder to save down the text file into a folder.
Sub PipeDelimited()
' Exports to PipeDel.txt file
Dim Rng As Range
Dim ws As Worksheet
Dim CurrRow As Range
Dim CurrCell As Range
Dim CurrTextStr As String
Dim ListSep As String
Dim DestFile As String
ListSep = "|"
Set ws = ThisWorkbook.Worksheets("jj")
Set Rng = Worksheets("jj").UsedRange
DestFile ====> use msoFileDialogFolderPicker??????
File name is set under Cell d8 in the tab (sheet) called macros
Open DestFile For Output As #1
For Each CurrRow In Rng.Rows
CurrTextStr = ""
For Each CurrCell In CurrRow.Cells
CurrTextStr = CurrTextStr & CurrCell.Value & ListSep
Next
While Right(CurrTextStr, 1) = ListSep
CurrTextStr = Left(CurrTextStr, Len(CurrTextStr) - 1)
Wend
'Added next line to put | at end of each line
CurrTextStr = CurrTextStr & ListSep
Print #1, CurrTextStr
Next
Close #1
End Sub
I have now added this sub with the intention that the vba script will automatically place a suffix of txt to my file.
The sub below does default my file type to txt. However, when I click on ok, nothing happens. The pop up window "please choose folder location to save this file" pops up each time I click on "ok". However, the file doesn't get saved.
Sub FolderLocation()
Dim folderpath As String
Dim fn As String
Dim fd As FileDialog
fn = ThisWorkbook.Worksheets("MACROS").Range("RngFileName").Value
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.Title = "Please Choose Folder Location to Save this File"
fd.InitialFileName = ThisWorkbook.Worksheets("Macros").Range("RngFileName").Value
fd.AllowMultiSelect = False
fd.Filters.Add "All Files", "*.*"
fd.Filters.Add "Text", "*.txt", 1
fd.FilterIndex = 1
If fd.Show = True Then folderpath = fd.SelectedItems(1)
MsgBox "File Saved", vbOKCancel, folderpath
End Sub
Adapt this basic outline for your code. You will need to concatenate your filename to the selectedFolder path.
Sub getFolder()
Dim newFldrDia As FileDialog
Dim selectedFolder As String
Set newFldrDia = Application.FileDialog(msoFileDialogFolderPicker)
With newFldrDia
.Title = "My Dialog Title"
.AllowMultiSelect = False
If .Show = -1 Then
selectedFolder = .SelectedItems(1)
End If
End With
MsgBox selectedFolder
End Sub
Have a look here for more properties/methods you can use.