I have Excel workbook from where I am inserting data to embedded (inside my workbook) Word file. I have predefined bookmarks. I am inserting bookmark text from Excel workbook cells. Everything works fine except for deleting imported data from bookmarks. The problem is that with my code, after several runs keeps recording data to bookmarks. So, for example, after 3 runs I have "SwedenSwedenSweden".
I would like to null bookmarks before inserting data objWord.Bookmarks.Item("Country").Range = "" does not seems to work. With this command I am trying to null bookmarks before entering new ones and after exiting my Template Word document. Any good solutions?
Sub testInsertBookmark()
Const wdFormatDocument = 0
Dim sh As Shape
Dim objWord As Object ''Word.Document
Dim objOLE As OLEObject
Dim wSystem As Worksheet
Dim BMRange As Range
On Error Resume Next
Set wSystem = Worksheets("Templates")
''The shape holding the object from 'Create from file'
''Object 2 is the name of the shape
Set sh = wSystem.Shapes("Object 1")
''Activate the contents of the object
sh.OLEFormat.Activate
''The OLE Object contained
Set objOLE = sh.OLEFormat.Object
''This is the bit that took time
Set objWord = objOLE.Object
objWord.Bookmarks.Item("Name").Range = ""
objWord.Bookmarks.Item("Title").Range = ""
objWord.Bookmarks.Item("Telephone").Range = ""
objWord.Bookmarks.Item("Company").Range = ""
objWord.Bookmarks.Item("Address").Range = ""
objWord.Bookmarks.Item("Postcode").Range = ""
objWord.Bookmarks.Item("City").Range = ""
objWord.Bookmarks.Item("Country").Range = ""
objWord.Bookmarks.Item("Name").Range.Text = ThisWorkbook.Sheets("MAIN").Range("D5").Value
objWord.Bookmarks.Item("Title").Range.Text = ThisWorkbook.Sheets("MAIN").Range("D6").Value
objWord.Bookmarks.Item("Telephone").Range.Text = ThisWorkbook.Sheets("MAIN").Range("D7").Value
objWord.Bookmarks.Item("Company").Range.Text = ThisWorkbook.Sheets("MAIN").Range("D8").Value
objWord.Bookmarks.Item("Address").Range.Text = ThisWorkbook.Sheets("MAIN").Range("D9").Value
objWord.Bookmarks.Item("Postcode").Range.Text = ThisWorkbook.Sheets("MAIN").Range("D10").Value
objWord.Bookmarks.Item("City").Range.Text = ThisWorkbook.Sheets("MAIN").Range("D11").Value
objWord.Bookmarks.Item("Country").Range.Text = ThisWorkbook.Sheets("MAIN").Range("D12").Value
objWord.Application.Visible = True
''Easy enough
objWord.SaveAs2 ActiveWorkbook.Path & "\" & Sheets("Other Data").Range("AN2").Value & ", " & Sheets("Other Data").Range("AN7").Value & "_" & Sheets("Other Data").Range("AN8").Value & "_" & Sheets("Other Data").Range("AX10").Value & ".pdf", 17
objWord.Bookmarks.Item("Name").Range = ""
objWord.Bookmarks.Item("Title").Range = ""
objWord.Bookmarks.Item("Telephone").Range = ""
objWord.Bookmarks.Item("Company").Range = ""
objWord.Bookmarks.Item("Address").Range = ""
objWord.Bookmarks.Item("Postcode").Range = ""
objWord.Bookmarks.Item("City").Range = ""
objWord.Bookmarks.Item("Country").Range = ""
sh.OLEFormat.Delete
ThisWorkbook.Worksheets("MAIN").Activate
End Sub
Writing data to a bookmark that marks a position (rather than contains content) will yield the result you describe. The way to get this to work is to use a bookmark that contains content - at least after the first insertion. When writing to such a bookmark it is deleted when the content is replaced, so it's necessary to recreate the bookmark, as well. For example:
Dim wdRange as Object 'Word.Range
Set wdRange = objWord.Bookmarks.Item("Name").Range
wdRange.Text = ThisWorkbook.Sheets("MAIN").Range("D5").Value
objWord.Bookmarks.Add "Name", wdRange
This recreates the bookmark around the new content. There's no need to delete the content / set it to "" as it will be replaced.
My suggestion would be to put this in a separate procedure that can be called from the main code. Pass in objWord, the bookmark name and the Excel Range or its data.
Related
Sorry for the long one, and it's probably something simple that I'm overlooking after so much time.
I'm writing a small program that in just a few clicks, pulls data from an actor's "deal memo" pdf and put's that info into one of four possible excel templates (in different sheets) to export as a new "contract" pdf.
The application identifies certain key words/values from other cells that determines which sheet/template is used.
The issue comes at the following step:
-Based on the keywords, I need the exported document to identify if a series of folders are created, and if not, create them, and step in to create more relevant folders before finally saving the file.
The structure example is as follows, relevant created folders in Bold:
C:\Work Folder\ Deal Memo to Contract\Exported Contracts\Episode Number\Actor Name\Contract Type\final.pdf
Each folder name is created based on variables pulled from cell values. It works just fine when I put the string variables in quotes for testing, and even when the variables are stated by themselves, it pastes the proper path in the admin cells as shown in the following picture - Range A14:A21
Screenshot of Dashboard Page, admin column to be hidden
But even though it looks like a proper path address in the cells, VBA throws a
Runtime error 52:Bad file name or number on line 56, "PlayerExFolder = Dir(PlayerExPath, vbDirectory)"
Like I said, it's probably something simple. Any help would be great as I'm still pretty new to this. Oh, and I'm working on the Daily_Direct section of the if statements, the others will be identical once this starts working. Thanks!
UPDATE - It turns out that I had narrowed it down to what I thought were extra spaces that were ruining the path/folder creation. They were invisible "Ghost" characters. Ended up using the Clean function on the cells that were being used to name the folders. Hope this helps someone in the future.
Sub export_pdf()
Application.ScreenUpdating = False
Dim MainExPath As String
Dim MainExFolder As String
MainExPath = Worksheets("Deal2Contract").Range("C3").Value & "\Exported Contracts"
MainExFolder = Dir(MainExPath, vbDirectory)
If MainExFolder = vbNullString Then
Answer = MsgBox("An export folder for the generated contracts does not exist, I will create one for you", vbOKCancel, "Create Contract Export Folder?")
Select Case Answer
Case vbOK
VBA.FileSystem.MkDir (MainExPath)
Case Else
End Select
End If
Worksheets("Deal2Contract").Range("A15").Value = MainExPath
Dim EpiExPath As String
Dim EpiExFolder As String
Dim currEp As Integer
currEp = Worksheets("Data").Range("F14").Value
EpiExPath = Worksheets("Deal2Contract").Range("A15").Value & "\" & currEp
Worksheets("Deal2Contract").Range("A17").Value = EpiExPath
Dim PlayerExPath As String
Dim PlayerExFolder As String
Dim CurrPlayer As String
CurrPlayer = Worksheets("Data").Range("F8").Value
PlayerExPath = Worksheets("Deal2Contract").Range("A17").Value & "\" & CurrPlayer
Worksheets("Deal2Contract").Range("A19").Value = PlayerExPath
Dim TypeExPath As String
Dim TypeExFolder As String
Dim CurrType As String
CurrType = Worksheets("Deal2Contract").Range("A7").Value
TypeExPath = Worksheets("Deal2Contract").Range("A19").Value & "\" & CurrType
Worksheets("Deal2Contract").Range("A21").Value = TypeExPath
If Worksheets("Deal2Contract").Range("A7").Value = "Weekly_Direct" Then
ElseIf Worksheets("Deal2Contract").Range("A7").Value = "Weekly_Loan" Then
ElseIf Worksheets("Deal2Contract").Range("A7").Value = "Daily_Direct" Then
EpiExFolder = Dir(EpiExPath, vbDirectory)
If EpiExFolder = vbNullString Then
VBA.FileSystem.MkDir (EpiExPath)
Else
End If
PlayerExFolder = Dir(PlayerExPath, vbDirectory)
If PlayerExFolder = vbNullString Then
VBA.FileSystem.MkDir (PlayerExPath)
Else
End If
TypeExFolder = Dir(TypeExPath, vbDirectory)
If TypeExFolder = vbNullString Then
VBA.FileSystem.MkDir (TypeExPath)
Else
End If
'dateExFolder = Dir(dateExPath, vbDirectory)
'If typeExFolder = vbNullString Then
' VBA.FileSystem.MkDir (currType)
'Else
'End If
ElseIf Worksheets("Deal2Contract").Range("A7").Value = "Daily_Loan" Then
End If
Worksheets("Deal2Contract").Range("A15").WrapText = False
Worksheets("Deal2Contract").Range("A17").WrapText = False
Worksheets("Deal2Contract").Range("A19").WrapText = False
Worksheets("Deal2Contract").Range("A21").WrapText = False
Worksheets("Deal2Contract").Range("A23").WrapText = False
Application.ScreenUpdating = True
End Sub
I have made a Word template and inserted it to Excel as an object. I am opening it with the code and inputting data to bookmarks and main part. However after code is done doing processes my embedded template has all the data inside. So it is not a template anymore but a file I have created with the code.
Embedded Word template should be opened as a copy, as I do not want to make any changes to original embedded template or null it with the code all the time (or is it the only way it possible to do?). Is it anyhow possible with the code to open embedded Word document as a copy, make changes to it and save as a Word document? I can't find anything useful in the internet.
Sub opentemplateWord()
Dim sh As Shape
Dim objWord As Object ''Word.Document
Dim objOLE As OLEObject
Dim wSystem As Worksheet
Dim cell As Range
Set wSystem = Worksheets("Templates")
''The shape holding the object from 'Create from file'
''Object 2 is the name of the shape
Set sh = wSystem.Shapes("Object 2")
''Activate the contents of the object
sh.OLEFormat.Activate
''The OLE Object contained
Set objOLE = sh.OLEFormat.Object
''This is the bit that took time
Set objWord = objOLE.Object
'>------- This Part Inputs Bookmarks
objWord.Bookmarks.Item("ProjectName1").Range.Text = ThisWorkbook.Sheets("MAIN").Range("D15").Value
objWord.Bookmarks.Item("ProjectName2").Range.Text = ThisWorkbook.Sheets("MAIN").Range("D16").Value
'>------- This Part Inputs Text
'ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument '<--- This is for closing footer and header?
With objWord '<--| reference 'Selection' object
For Each cell In ThisWorkbook.Worksheets("Offer Letter").Range("C1", ThisWorkbook.Worksheets("Offer Letter").Range("C" & Rows.Count).End(xlUp))
Select Case LCase(cell.Value)
Case "title"
.TypeParagraph
.Style = objWord.ActiveDocument.Styles("Heading 1")
.TypeText Text:=cell.Offset(0, -1).Text
Case "main"
.TypeParagraph
.Style = objWord.ActiveDocument.Styles("Heading 2")
.TypeText Text:=cell.Offset(0, -1).Text
Case "sub"
.TypeParagraph
.Style = objWord.ActiveDocument.Styles("Heading 3")
.TypeText Text:=cell.Offset(0, -1).Text
Case "sub-sub"
.TypeParagraph
.Style = objWord.ActiveDocument.Styles("Heading 4")
.TypeText Text:=cell.Offset(0, -1).Text
End Select
Next cell
End With
objWord.Application.Visible = False
''Easy enough
objWord.SaveAs2 ActiveWorkbook.Path & "\" & Sheets("Other Data").Range("AN2").Value & ", " & Sheets("Other Data").Range("AN7").Value & "_" & Sheets("Other Data").Range("AN8").Value & "_" & Sheets("Other Data").Range("AX2").Value & ".docx"
End Sub
This is an interesting task which I haven't looked at in a few years... The trick is to open the document in the Word application interface, instead of in-place in Excel.
I've adapted the code in the question. In order to make it easier to follow (shorter) I've removed the editing in the Word document except for writing to a couple of bookmarks. That can, of course, be put back in.
I very much recommend using VBA to assign a name to the Shape. Office applications feel free to change a generic name they assign, so relying on "Object 2" could, sometime down the line, lead to problems.
Do NOT use the Activate method in this scenario (commented out). If the object is already activated in-place the document cannot be opened in the Word.Application.
Use the OLEFormat.Object.Verb method with the parameter xlOpen to open the document in Word.
Once it's open, the OLE object can be set to a Word document object.
From your comments: 'ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument '<--- This is for closing footer and header? No. Better to work with the corresponding Range objects. There are lots of examples "out there" for that. Ask a new question if you run into problems using them.
A Word document opened in the Word application can be saved as a file (a document opened in-place cannot). The question about not saving edits, however... there are two basic approaches:
SaveAs before editing, open that document, edit and save. The original should then be untouched
Do the editing in the object, save then undo the changes. This approach is shown in the code sample
Word's object model is able to group any number of actions into a single "undo record".
Set objUndo = objWord.Application.UndoRecord
objUndo.StartCustomRecord "Edit In Word"
After the editing has been done, to get back to an "empty" (unchanged) document:
objUndo.EndCustomRecord
Set objUndo = Nothing
objWord.Undo
Finally, to close the document quit the Word application without saving changes.
Sub opentemplateWord()
Dim sh As Shape
Dim objWord As Object, objNewDoc As Object ''Word.Document
Dim objOLE As OLEObject
Dim wSystem As Worksheet
Dim cell As Range
Set wSystem = Worksheets("Templates")
''The shape holding the object from 'Create from file'
''Object 2 is the name of the shape
Set sh = wSystem.Shapes("WordFile")
''The OLE Object contained
Set objOLE = sh.OLEFormat.Object
'Instead of activating in-place, open in Word
objOLE.Verb xlOpen
Set objWord = objOLE.Object 'The Word document
Dim objUndo As Object 'Word.UndoRecord
'Be able to undo all editing performed by the macro in one step
Set objUndo = objWord.Application.UndoRecord
objUndo.StartCustomRecord "Edit In Word"
With objWord
.Bookmarks.Item("ProjectName1").Range.Text = ThisWorkbook.Sheets("MAIN").Range("D15").Value
.Bookmarks.Item("ProjectName2").Range.Text = ThisWorkbook.Sheets("MAIN").Range("D16").Value
objWord.SaveAs2 ActiveWorkbook.Path & "\" & Sheets("Other Data").Range("AN2").Value & _
", " & Sheets("Other Data").Range("AN7").Value & "_" & _
Sheets("Other Data").Range("AN8").Value & "_" & _
Sheets("Other Data").Range("AX2").Value & ".docx"
objUndo.EndCustomRecord
Set objUndo = Nothing
objWord.Undo
.Application.Quit False
End With
Set objWord = Nothing
End Sub
I am doing the same thing and used this post for reference.
I got rid of objUndo object and CustomRecord methods.
Instead, I used the Duplicate method on the OLEobject to protect the original emmbedded doc from being edited. Seemed easier this way. The previous duplicates get removed at beginning so they don't pile up to infinity.
Sub opentemplateWord_v2()
Dim wSheet As Worksheet
Dim sh As Shape
Dim objOLE As OLEObject '<-- og emmbeded doc
Dim objOLE2 As OLEObject '<-- duplicate doc
Dim objWord As Object
Set wSheet = Worksheets("TemplateSheet") '<-- worksheet embedded doc is on
'--remove all duplicates from previous runs
'
' *the original embedded doc is named 'Object 1'
' (seen by clicking on doc --> the 'Name Box' is at the top left)
'
For Each sh In wSheet.Shapes
If sh.Name <> "Object 1" Then sh.Delete
Next
Set sh = wSheet.Shapes("Object 1") '<-- set the shape to the embedded doc Object
Set objOLE = sh.OLEFormat.Object '<-- get the embedded object in shape
Set objOLE2 = objOLE.Duplicate '<-- create duplicate of embedded object
objOLE2.Verb xlOpen '<-- open duplicate doc in the Word application
Set objWord = objOLE2.Object '<-- The Word document
'~~~~~~~ do the stuff here ~~~~~~~~~~~~~~~~~~~~~~~~~
'
' for mine, I am going to find/replace keyfeilds on the document
' (this example is replacing "Planet" with "earth"
'
With objWord.Content.Find
.text = "Planet"
.Forward = True
.MatchWholeWord = True
.MatchCase = False
.Wrap = 1 'wdFindContinue
.Execute Replace:=1 'wdReplaceOne
If .Found = True Then .Parent.text = "earth"
End With
'-- No Save Action
' I amsume the user will want view/edit the output after execution,
' and save it in a specific place
'
End Sub
I am trying to export six recordsets generated by a Do-Loop to six specific tabs in a single MS Excel workbook using VBA. Instead of updating the single tabs, however, the code creates six open iterations of the workbook with only the first being editable, the remainder read-only. The recordsets are successfully exported into the correct tab in the desired format.
Function ExportRecordset2XLS2(ByVal rs As DAO.Recordset, strSheetName)
Dim xls As Object
Dim xlwb As Object
Dim xlws As Object
Dim fld As DAO.Field
Dim strPath As String07
Dim strTitleRange,strHeaderRange, strBodyRange as String
On Error GoTo err_handler
strPath = "C:\Database\Roster.xlsx"
Set xls = CreateObject("Excel.Application")
Set xlwb = xls.Workbooks.Open(strPath)
xls.Visible = False
xls.ScreenUpdating = False
Set xlws = xlwb.Worksheets(strSheetName)
xlws.Activate
'Define ranges for formatting
intFields = rs.Fields.Count
intRows = rs.RecordCount
strTitleRange = "A1:" & Chr(64 + intFields) & "1"
strHeaderRange = "A2:" & Chr(64 + intFields) & "2"
strBodyRange = "A3:" & Chr(64 + intFields) & (intRows + 2)
'Build TITLE Row
xlws.Range("A1").Select
xls.ActiveCell = Format(Now(), "YYYY") & " Roster (" & strSheetName & ")"
'Build HEADER Row
xlws.Range("A2").Select
For Each fld In rs.Fields
xls.ActiveCell = fld.Name
xls.ActiveCell.Offset(0, 1).Select
Next
rs.MoveFirst
'Paste Recordset into Worksheet(strSheetName) starting in A3
xlws.Range("A3").CopyFromRecordset rs
On Error Resume Next
xls.Visible = True 'Make excel visible to the user
Set rs = Nothing
Set xlws = Nothing
Set xlwb = Nothing
xls.ScreenUpdating = True
Set xls = Nothing
xls.Quit
Exit Function
err_handler:
DoCmd.SetWarnings True
MsgBox Err.Description, vbExclamation, Err.Number
Exit Function
End Function
I suspect the problem revolves around how the function opens the .xlsx file for editing; I have tried programmatically closing the active worksheet and/or workbook in various ways and sequences to no effect. I could presumably insert a break into the code that generates the recordset to allow MS Excel to open then close, before repeating the process with the next tab, but there must be a more elegant way.
Image of multiple iterations in Excel
** As a side note, I did post this question also to answers.microsoft.com before finding this forum. Sorry. **
Thanks in advance, Erik
For each workbook opened you can check the security and reset it so it can be edited:
If Application.ProtectedViewWindows.Count > 0 Then
Application.ActiveProtectedViewWindow.Edit
End If
As expected, this turned out to be series of small issues that resulted in MS Excel holding the workbook file in read-only status after the function would error out. SOlved after scrutinizing each line of code to find individual lines that were failing.
Try this methodology and feedback.
Dim qdf As DAO.QueryDef
Dim dbs As DAO.Database
Dim rstMgr As DAO.Recordset
Dim strSQL As String, strTemp As String, strMgr As String
' Replace PutEXCELFileNameHereWithoutdotxls with actual EXCEL
' filename without the .xls extension
' (for example, MyEXCELFileName, BUT NOT MyEXCELFileName.xls)
Const strFileName As String = "PutEXCELFileNameHereWithoutdotxls"
Const strQName As String = "zExportQuery"
Set dbs = CurrentDb
' Create temporary query that will be used for exporting data;
' we give it a dummy SQL statement initially (this name will
' be changed by the code to conform to each manager's identification)
strTemp = dbs.TableDefs(0).Name
strSQL = "SELECT * FROM [" & strTemp & "] WHERE 1=0;"
Set qdf = dbs.CreateQueryDef(strQName, strSQL)
qdf.Close
strTemp = strQName
' *** code to set strSQL needs to be changed to conform to your
' *** database design -- ManagerID and EmployeesTable need to
' *** be changed to your table and field names
' Get list of ManagerID values -- note: replace my generic table and field names
' with the real names of the EmployeesTable table and the ManagerID field
strSQL = "SELECT DISTINCT ManagerID FROM EmployeesTable;"
Set rstMgr = dbs.OpenRecordset(strSQL, dbOpenDynaset, dbReadOnly)
' Now loop through list of ManagerID values and create a query for each ManagerID
' so that the data can be exported -- the code assumes that the actual names
' of the managers are in a lookup table -- again, replace generic names with
' real names of tables and fields
If rstMgr.EOF = False And rstMgr.BOF = False Then
rstMgr.MoveFirst
Do While rstMgr.EOF = False
' *** code to set strMgr needs to be changed to conform to your
' *** database design -- ManagerNameField, ManagersTable, and
' *** ManagerID need to be changed to your table and field names
' *** be changed to your table and field names
strMgr = DLookup("ManagerNameField", "ManagersTable", _
"ManagerID = " & rstMgr!ManagerID.Value)
' *** code to set strSQL needs to be changed to conform to your
' *** database design -- ManagerID, EmployeesTable need to
' *** be changed to your table and field names
strSQL = "SELECT * FROM EmployeesTable WHERE " & _
"ManagerID = " & rstMgr!ManagerID.Value & ";"
Set qdf = dbs.QueryDefs(strTemp)
qdf.Name = "q_" & strMgr
strTemp = qdf.Name
qdf.SQL = strSQL
qdf.Close
Set qdf = Nothing
' Replace C:\FolderName\ with actual path
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
strTemp, "C:\FolderName\" & strFileName & ".xls"
rstMgr.MoveNext
Loop
End If
rstMgr.Close
Set rstMgr = Nothing
dbs.QueryDefs.Delete strTemp
dbs.Close
Set dbs = Nothing
this is my first question so I would love to improve my style and such. Just tell me if I am doing something completely wrong.
My question:
I am searching files with a specific extensions. All results get printed to excel and then create shortcuts to each file which get then stored in a folder. This works perfectly fine for now, but I need the shortcut to include the author detail to filter all entries (hundreds to thousends) for it.
The result should be a shortcut with the same properties that you get when using the 'create shortcut' from context menu vie right click.
I hope you can help my since I am trying to get this to work for a while now.
If you know a solution, that does what I need but is maybe written in a different language that is fine for me as long as the user does not have to install runtimes/libraries (sory I am a complete beginner)
My code:
'This function searches for files with endings (ppt,pptx,pptm) and pastes the found entries into the excel sheet
Function Recurse(sPath As String) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim mySubFolder As Folder
Dim myFile As File
Set myFolder = FSO.GetFolder(sPath)
Set Extensions = CreateObject("Scripting.Dictionary")
Extensions.CompareMode = 1 ' make lookups case-insensitive
'Extensions.Add Range("C5").Value, True
Extensions.Add "pptx", True
Extensions.Add "ppt", True
Extensions.Add "pptm", True
For Each mySubFolder In myFolder.SubFolders
For Each myFile In mySubFolder.Files
'
i = Range("D4").Value
If Extensions.Exists(FSO.GetExtensionName(myFile)) Then
Cells(8 + i, 3).Value = myFile.Name
Cells(8 + i, 4).Value = myFile.Path
i = i + 1
Range("D4").Value = i 'storing number of entrys found
'Exit For
End If
Next
Recurse = Recurse(mySubFolder.Path)
Next
End Function
'This Function creates a folder with the name "A1" if it does not exist already
Function PathExist(ByVal vPfadName As String) As Boolean
scutPath = Application.ActiveWorkbook.Path & "\" & Range("A1").Value
On Error GoTo ErrorPathExist
ChDir (vPfadName)
PathExist = True
Exit Function
ErrorPathExist:
MkDir scutPath
End Function
'Main Function that clears table and uses the found entries to get create shortcuts. Unfortunately the author is not integrated when doing it this way. The author is necessary to filter through hundreds of results.
Sub TestR()
Range("B8:C999999") = ""
Range("D4").Value = 0
Call Recurse(Application.ActiveWorkbook.Path)
i = 1
scutPath = Application.ActiveWorkbook.Path & "\" & Range("A1").Value
Call PathExist(scutPath)
For i = 1 To 200 '(last line)
Set oWSH = CreateObject("WScript.Shell")
Set oShortcut = oWSH.CreateShortCut(scutPath & "\" & Cells(7 + i, 3).Value & ".lnk")
With oShortcut
.TargetPath = Cells(7 + i, 4).Value
.Save
End With
Set oWSH = Nothing
Next i
MsgBox "Done"
End Sub
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