VBA to open Excel file based on cell value WITHIN that file - excel

I've been looking all over the web for an answer to this question. I see many blogs and postings regarding opening an excel file based on a cell value NOT within that file.
My question: Is it possible to open a file based on a cell value within the file I am trying to open? Another way to word it: Can VBA search for a cell value within a file, that is not open, and then open that file if it finds that cell value?
Further Explanation:
I save reports from a system into a folder and these files being saved have a common name (Report, Report (1), Report (2), Report (3).....). However, the data within the reports are different. They all have a common cell (Cell A7) that designates what the report is for. I want to use VBA code to open one of these files based on its value in cell A7. Is this even possible?
Thank you in advanced for any direction here.

If you know the sheet name you can use ExecuteExcel4Macro. If the sheet name is not known then you can use ADO to get that first (easier here as there's only one sheet)
Example:
Sub Tester()
Const fldr As String = "C:\Excel\Temp\"
Dim f, v
f = Dir(fldr & "*.xlsx")
'loop over all files in folder
Do While Len(f) > 0
'passing empty string for sheetname, since we don't know it...
v = ReadCell(fldr, f, "", Range("A7").Address(True, True, xlR1C1))
Debug.Print f, v
f = Dir
Loop
End Sub
'Read a cell value given a workbook path, name, optional sheetname,
' and cell address (R1C1 format)
Function ReadCell(fPath, wbName, wsName, addr)
Const adSchemaTables = 20
Dim cn, conStr, rs
If Len(wsName) = 0 Then
'sheet name is not known, so find the first name using ADO
conStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & fPath & wbName & "';" & _
"Extended Properties=""Excel 12.0;HDR=NO;IMEX=1;"";"
Set cn = CreateObject("ADODB.connection")
cn.Open conStr
Set rs = cn.openschema(adSchemaTables)
wsName = Replace(rs("TABLE_NAME").Value, "$", "")
rs.Close
cn.Close
End If
ReadCell = ExecuteExcel4Macro("'" & fPath & "[" & wbName & "]" & _
wsName & "'!" & addr)
End Function

Related

VBA: How to get a (more) dynamic file name?

So I have a currently working VBA script. I just want to edit the name by which the loop saves files.
I'll give a quick description of what it is currently doing. Basically it loops a set of actions for a defined range of rows, here A2:A72. The is a 'main' workbook where this loop is done is where all the input data is collected. Each row is a separate subject's input data and is copy/pasted into a template in a different workbook. Solver is then run to adjust the template for the given input data. Then it saves and names file as the text in the first cell of the row that was copy pasted. (ie A2,A3,A4,etc..) It then loops this for every row and every row will have its own template set up and saved separately.
This is ALMOST how I ideally want it to work.
I just want it save the File name not just as A2, but as =C2&" - "&A2
I tried using this that was suggested by someone
fName = Range("C" & c.Row) & Range("A" & c.Row)
But when I tried I would get a Method SaveAs error. On the watch view I could see it was because it wasn't reading the fName so it was just the file path in the script value. I changed it back to c.Value and then it started working by naming the file as the A column cell. Admittedly, I don't really understand how c.Value is returning column A which makes it harder for me to figure out how to modify it to get what I want.
Anyway here is the script as I currently have it:
Sub RunModels()
Dim fPath As String
Dim strTemplate As String
Dim fName As String
Dim wb As Workbook
Dim c As Range
Dim rngLoop As Range
'Where will files get stored?
fPath = "H:\ACQUISITIONS\Personal (D-AP)\Gmo\ALL MF"
'Where is the template file?
strTemplate = "H:\ACQUISITIONS\Personal (D-AP)\Gmo\ALL MF\Garden Grove - 11121 Chapman Ave.xlsm"
'Error check
If Right(fPath, 1) <Application.PathSeparator Then
fPath = fPath & Application.PathSeparator
End If
Application.ScreenUpdating = False
'Set Loop
Set rngLoop = ThisWorkbook.Worksheets("Sheet1").Range("A2:A72")
'Set Looped Actions
For Each c In rngLoop.Cells
'Open the template file
Set wb = Workbooks.Open(strTemplate)
'Add some data to the template file
c.EntireRow.Copy Destination:=wb.Worksheets("Insert
Sheet").Range("A2")
SolverOk SetCell:="$H$20", MaxMinVal:=3, ValueOf:=1.2, ByChange:="$F$35", Engine:=1, EngineDesc:="GRG Nonlinear"
SolverSolve
'Dynamic File Naming
fName = c.Value
'Save the file and close
wb.SaveAs Filename:=wb.Path & Application.PathSeparator & fName
wb.Close
Next c
Application.ScreenUpdating = True
End Sub
Thank you very very much for all and any help!!
You should not use wb.Path wb is assigned to the workbook, where fPath is your folder path, so use:
Filename:=fPath & "\" & fName & ".xlsx"
or ".xlsm" as required.
To assign fName use:
fName = c.Offset(, 2).Value & " - " & c.Value
The code assigns the variable c to each cell in the range A2:A72 in turn - so at the moment it is saving the code 71 times. The code
fName = Range("C" & c.Row) & Range("A" & c.Row)
would produce c2 & A2 on the first time through, and then C3 & A3 on the second (and so on. I suspect you'd like it to always use c2 and then add the value in A - in which case you'd need
Fname = Range("C2") & "- " & c

Using ADODB to write to Excel file

I hope someone can give me some direction using the ADODB methods to accomplish my goal.
Brief explanation:
Currently I have code in Outlook VBA that searches an email. If the email passes criteria the Outlook macro opens an Excel workbook, loops through column A to see if an ID number exists. If it does it updates other columns (1 or more columns), if not it creates a new row and writes data into Columns A-C for that row. Then saves and closes the workbook.
I want to speed up the process and the limiting factor is opening the excel workbook (located on a share drive). I have used a simple ADODB macro to read data in another workbook and have seen the speed increases possible. I want to implement that here.
I have been able to establish connection to the workbook from Outlook and place data into a recordset. BUT I don't know how to "loop" through the first column to see if the ID exists yet or not, and further more how to write data into the columns in the workbook (UPDATE SQL command?).
ExcelConnection Code:
Public Sub ExcelConnect(msg As Outlook.MailItem, LType As String)
Dim lngrow As Long
Dim SourceFile As Variant 'used
Dim SourceSheet As String 'used
Dim SourceRange As String 'used
SourceFile = "T:\Capstone Proj\TimeStampsOnlyTest.xlsx"
SourceSheet = "Timestamps"
SourceRange = "A2:F500"
Dim rsCon As Object 'used
Dim rsData As Object 'used
Dim szConnect As String ' used
Dim szSQL As String ' used
Dim lCount As Long
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=Yes"";"
End If
szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")
rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1
'***Need Help implementing a way to find exisiting ID numbers, or if Exisiting = 0 then INSERT new row into worksheet***'
Select Case LType '// Choose which columns based on Type
Case "MDIQE"
' If columnvalue = 0 Then
' Update column value
Case "MDIQ"
' If columnvalue = 0 Then
' Update column value
'
'........
'
Case "MDIF"
' If columnvalue = 0 Then
' Update column value
'
End Select
'Error handing & success messagebox
End sub
Thank you for the help,
Wagner
In your SELECT statement, include a WHERE clause to search for the ID in column A, something like this:
SELECT COUNT(*) c
FROM [sourceSheet$sourceRange]
WHERE <ColumnAName> = <ID>
note, this is pseudocode, you'll have to properly assemble the statement just like you did when you assigned a string to szSQL
Then check your result set for the value of c, something like this:
If rsData.Fields("c").value = 0 Then
'ID was NOT found, execute SQL INSERT here
Else
'ID was found, execute SQL UPDATE here
End If
i.e., treat your Excel worksheet like a database.
Of course, it would be better if you could use Access as a database (or SQL Server, or Oracle, or ...) since, well, that's what they're designed to do. But I understand that sometimes you've just got to roll with what you've got.

classic asp sorting alphanumeric values from Excel using order by

I am listing a load of spare parts on a web page which is supplied to me weekly by my supplier. I just upload the .xlsx file to the web folder and the page populates itself. The object is not to change the file in any way so no work is involved. In classic ASP I am using
Set objConn = Server.CreateObject("ADODB.Connection")
objConn.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};"&_
"DBQ=" & Server.MapPath(file) & ";"
strSQL = "SELECT * FROM A1:D10000 order by ""Item number"" ASC"
Set objRS=objConn.Execute(strSQL)
Item number is the part number which can be numeric or alphanumeric
the problem is the order is not correct
example
x1
x11
x111
x2
x22
x222
when it should be
x1
x2
x11
x22
x111
x222
I understand why this is happening but can't find a way of getting the order correct
Everything else works really well but customers are not expecting to find X1000 before x200 and it has caused a few problems
Many thanks in advance for any help supplied
EDIT: updated with my full test code and input/output.
I'm running this in Excel, but I just confirmed it in a simple ASP page...
Sub TestQuery()
Dim oConn As New ADODB.Connection
Dim oRS As New ADODB.Recordset
Dim sPath
Dim sSQL As String
sSQL = " select [Item Number], [Name] from " & _
" D22:E34 order by 1*right([Item Number],len([Item Number])-1) "
sPath = ThisWorkbook.Path & "\" & ThisWorkbook.Name
oConn.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
"DBQ=" & sPath & ";"
Set oRS = oConn.Execute(sSQL)
If Not oRS.EOF And Not oRS.BOF Then
ToSheet Sheet1.Range("H22"), oRS
Else
MsgBox "No records found"
End If
End Sub
Sub ToSheet(rng, rs)
Dim f, i
i = 0
For Each f In rs.Fields
rng.Offset(0, i).Value = f.Name
i = i + 1
Next f
rng.Offset(1, 0).CopyFromRecordset rs
End Sub
For this kind of problem in Excel, one solution is to split the data into the numeric and alpha portions, using "helper columns", and then sort on the helper columns.
Depending on what your real data looks like, you might use these formulas:
Alpha (first) section
=LEFT(A1,MIN(FIND({0;1;2;3;4;5;6;7;8;9},A1&"0123456789"))-1)
Numeric (second) section
=MID(A1,MIN(FIND({0;1;2;3;4;5;6;7;8;9},A1&"0123456789")),99)

How to query UTF-8 encoded CSV-files with VBA in Excel 2010?

I would like to query an UTF-8 encoded CSV file using VBA in Excel 2010 with the following database connection:
provider=Microsoft.Jet.OLEDB.4.0;;data source='xyz';Extended Properties="text;HDR=Yes;FMT=Delimited(,);CharacterSet=65001"
All CSV files start with the BOM \xEF\xBB\xBF and the header line. Somehow the BOM isn't recognized correctly and the first column header gets read as "?header_name", i.e. a question mark gets prepended. I have tried different CharacterSets and I have also tried to use Microsoft.ACE.OLEDB.12.0, but everything was without success so far.
Is this a known bug or is there any way to get the right first column header name without changing the encoding of the source files?
The following procedure extracts the entire CSVfile into a new Sheet, clearing the BOM from the Header. It has the Path, Filename and BOM string as variables to provide flexibility.
Use this procedure to call the Query procedure
Sub Qry_Csv_Utf8()
Const kFile As String = "UTF8 .csv"
Const kPath As String = "D:\StackOverFlow\Temp\"
Const kBOM As String = "\xEF\xBB\xBF"
Call Ado_Qry_Csv(kPath, kFile, kBOM)
End Sub
This is the Query procedure
Sub Ado_Qry_Csv(sPath As String, sFile As String, sBOM As String)
Dim Wsh As Worksheet
Dim AdoConnect As ADODB.Connection
Dim AdoRcrdSet As ADODB.Recordset
Dim i As Integer
Rem Add New Sheet - Select option required
'With ThisWorkbook 'Use this if procedure is resident in workbook receiving csv data
'With Workbooks(WbkName) 'Use this if procedure is not in workbook receiving csv data
With ActiveWorkbook 'I used this for testing purposes
Set Wsh = .Sheets.Add(After:=.Sheets(.Sheets.Count))
'Wsh.Name = NewSheetName 'rename new Sheet
End With
Set AdoConnect = New ADODB.Connection
AdoConnect.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & sPath & ";" & _
"Extended Properties='text;HDR=Yes;FMT=Delimited(,);CharacterSet=65001'"
Set AdoRcrdSet = New ADODB.Recordset
AdoRcrdSet.Open Source:="SELECT * FROM [" & sFile & "]", _
ActiveConnection:=AdoConnect, _
CursorType:=adOpenDynamic, _
LockType:=adLockReadOnly, _
Options:=adCmdText
Rem Enter Csv Records in Worksheet
For i = 0 To -1 + AdoRcrdSet.Fields.Count
Wsh.Cells(1, 1 + i).Value = _
WorksheetFunction.Substitute(AdoRcrdSet.Fields(i).Name, sBOM, "")
Next
Wsh.Cells(2, 1).CopyFromRecordset AdoRcrdSet
End Sub
The only solution for this problem I found is to use Schema.ini file.
my test csv file
Col_A;Col_B;Col_C
Some text example;123456789;3,14
Schema.ini for my test csv file
[UTF-8_Csv_With_BOM.csv]
Format=Delimited(;)
Col1=Col_A Text
Col2=Col_B Long
Col3=Col_C Double
This Schema.ini file contains the name of the source csv file and describes my columns. Each column is specified by its name and type but you can specify more informations. This file must be located in the same folder as your csv file. More info here.
Finally the VBA code which reads the csv file. Note that HDR=No. This is because the columns headers are defined in the Schema.ini.
' Add reference to Microsoft ActiveX Data Objects 6.1 Library
Sub ReadCsv()
Const filePath As String = "c:\Temp\StackOverflow\"
Const fileName As String = "UTF-8_Csv_With_BOM.csv"
Dim conn As ADODB.Connection
Dim rs As New ADODB.Recordset
Set conn = New ADODB.Connection
conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source='" & filePath & _
"';Extended Properties='text;HDR=No;FMT=Delimited()';"
With rs
.ActiveConnection = conn
.Open "SELECT * FROM [" & fileName & "]"
If Not .BOF And Not .EOF Then
While (Not .EOF)
Debug.Print rs.Fields("Col_A") & " " & _
rs.Fields("Col_B") & " " & _
rs.Fields("Col_C")
.MoveNext
Wend
End If
.Close
End With
conn.Close
Set conn = Nothing
End Sub
Output
Some text example 123456789 3,14

Vba to import a sub-portion of a hugh csv file into excel 2010

I have a csv file that has approx 600 fields and approx 100k of rows, i would like to import only select fields and only certian rows where a select set of fields match a certain set of criteria into an existing excel worksheet tab
I attempted to use ms query within excel but it stops at 255 columns, i can import the whole file in excel 2010 (250m) but it is a memory hog and by the time i remove the unneeded fields and rows it locks up my computer.
I would like to kick the import process off with an excel vba macro. I have all the front end code of file selection, etc.... But need some assistance in the text read query convert to excel area of vba
Any assitance would be greatly appreciated
Thanks
Tom
For that many records you would be better off importing the .csv into Microsoft Access, indexing some fields, writing a query that contains only what you want, and then exporting to Excel from the query.
If you really need an Excel-only solution, do the following:
Open up the VBA editor. Navigate to Tools -> References. Select the most recent ActiveX Data Objects Library. (ADO for short). On my XP machine running Excel 2003, it's version 2.8.
Create a module if you don't have one already. Or create one anyway to contain the code at the bottom of this post.
In any blank worksheet paste the following values starting at cell A1:
SELECT Field1, Field2
FROM C:\Path\To\file.csv
WHERE Field1 = 'foo'
ORDER BY Field2
(Formatting issues here. select from, etc should each be in their own row in col A for reference. The other stuff are the important bits and should go in column B.)
Amend the input fields as appropriate for your filename and query requirements, then run thegetCsv() subroutine. It will put the results in a QueryTable object starting at cell C6.
I personally hate QueryTables but the .CopyFromRecordset method I prefer to use with ADO doesn't give you field names. I left the code for that method in, commented out, so you can investigate that way. If you use it, you can get rid of the call to deleteQueryTables() because it's a really ugly hack, it deletes whole columns which you may not like, etc.
Happy coding.
Option Explicit
Function ExtractFileName(filespec) As String
' Returns a filename from a filespec
Dim x As Variant
x = Split(filespec, Application.PathSeparator)
ExtractFileName = x(UBound(x))
End Function
Function ExtractPathName(filespec) As String
' Returns the path from a filespec
Dim x As Variant
x = Split(filespec, Application.PathSeparator)
ReDim Preserve x(0 To UBound(x) - 1)
ExtractPathName = Join(x, Application.PathSeparator) & Application.PathSeparator
End Function
Sub getCsv()
Dim cnCsv As New ADODB.Connection
Dim rsCsv As New ADODB.Recordset
Dim strFileName As String
Dim strSelect As String
Dim strWhere As String
Dim strOrderBy As String
Dim strSql As String
Dim qtData As QueryTable
strSelect = ActiveSheet.Range("B1").Value
strFileName = ActiveSheet.Range("B2").Value
strWhere = ActiveSheet.Range("B3").Value
strOrderBy = ActiveSheet.Range("B4").Value
strSql = "SELECT " & strSelect
strSql = strSql & vbCrLf & "FROM " & ExtractFileName(strFileName)
If strWhere <> "" Then strSql = strSql & vbCrLf & "WHERE " & strWhere
If strOrderBy <> "" Then strSql = strSql & vbCrLf & "ORDER BY " & strOrderBy
With cnCsv
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Data Source=" & ExtractPathName(strFileName) & ";" & _
"Extended Properties=""text;HDR=yes;FMT=Delimited(,)"";Persist Security Info=False"
.Open
End With
rsCsv.Open strSql, cnCsv, adOpenForwardOnly, adLockReadOnly, adCmdText
'ActiveSheet.Range("C6").CopyFromRecordset rsCsv
Call deleteQueryTables
Set qtData = ActiveSheet.QueryTables.Add(rsCsv, ActiveSheet.Range("C6"))
qtData.Refresh
rsCsv.Close
Set rsCsv = Nothing
cnCsv.Close
Set cnCsv = Nothing
End Sub
Sub deleteQueryTables()
On Error Resume Next
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim qt As QueryTable
Dim qtName As String
Dim nName As Name
For Each qt In ActiveSheet.QueryTables
qtName = qt.Name
qt.Delete
For Each nName In Names
If InStr(1, nName.Name, qtName) > 0 Then
Range(nName.Name).EntireColumn.Delete
nName.Delete
End If
Next nName
Next qt
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
You can parse your input file extracting the lines that conform to your criteria. The following code uses the split function on each line of the CSV file to separate the fields and then checks to see if it matches the required criteria. If all the criteria match then selected fields are saved in a new CSV file then you can just open the smaller file. You will need to set the microsoft scripting runtime reference in the VBA editor for this to work.
This method should use little memory as it processes 1 line at a time, I tested it on data of 600 fields and 100000 lines and it took about 45 seconds to process the file with no noticable increase in RAM usage in windows task manager. It is CPU intensive and the time taken would increase as the complexity data, conditions and the number of fields copied increases.
If you prefer to write directly to an existing sheet this can be easily acheived, but you would have to rememove any old data there first.
Sub Extract()
Dim fileHandleInput As Scripting.TextStream
Dim fileHandleExtract As Scripting.TextStream
Dim fsoObject As Scripting.FileSystemObject
Dim sPath As String
Dim sFilenameExtract As String
Dim sFilenameInput As String
Dim myVariant As Variant
Dim bParse As Boolean 'To check if the line should be written
sFilenameExtract = "Exctract1.CSV"
sFilenameInput = "Input.CSV"
Set fsoObject = New FileSystemObject
sPath = ThisWorkbook.Path & "\"
'Check if this works ie overwrites existing file
If fsoObject.FileExists(sPath & sFilenameExtract) Then
Set fileHandleExtract = fsoObject.OpenTextFile(sPath & sFilenameExtract, ForWriting)
Else
Set fileHandleExtract = fsoObject.CreateTextFile((sPath & sFilenameExtract), True)
End If
Set fileHandleInput = fsoObject.OpenTextFile(sPath & sFilenameInput, ForReading)
'extracting headers for selected fields in this case the 1st, 2nd and 124th fields
myVariant = Split(fileHandleInput.ReadLine, ",")
fileHandleExtract.WriteLine (myVariant(0) & "," & _
myVariant(1) & "," & _
myVariant(123))
'Parse each line (row) of the inputfile
Do While Not fileHandleInput.AtEndOfStream
myVariant = Split(fileHandleInput.ReadLine, ",")
'Set bParse initially to true
bParse = True
'Check if the first element is greater than 123
If Not myVariant(0) > 123 Then bParse = False
'Check if second element is one of allowed values
'Trim used to remove pesky leading or lagging values when checking
Select Case Trim(myVariant(1))
Case "Red", "Yellow", "Green", "Blue", "Black"
'Do nothing as value found
Case Else
bParse = False 'As wasn't a value in the condition
End Select
'If the conditions were met by the line then write specific fields to extract file
If bParse Then
fileHandleExtract.WriteLine (myVariant(0) & "," & _
myVariant(1) & "," & _
myVariant(123))
End If
Loop
'close files and cleanup
fileHandleExtract.Close
fileHandleInput.Close
Set fileHandleExtract = Nothing
Set fileHandleInput = Nothing
Set fsoObject = Nothing
End Sub

Resources