Running an old Classic ASP site, and up to now I made my own "Excel" file with HTML, that gets sent to our accounting dept. They've revised the Excel file they want us to use, so I can't use my old method. So I'm connecting to the excel file directly (ADODB), and I can update the necessary cells easily enough. The problem is that they've added some fields at the bottom of the "form", including some with SUM() formulas, and left 34 rows for entries in the middle. We often need more than that.
I've tried "insert into" sql, and tried "rs.AddNew", and those both put the data into the row below the range I'm targeting; fair enough. However a NEW ROW is not added to the file - the data goes into the row below. It isn't like inserting a row manually in Excel, and pushing any lower rows further down. Does anyone know how I can do this through ADO/SQL? Or is it simply impossible?
As a last resort, I'll just have to create an extra document to hold the overflow past 34 entries.
Thanks!
I finally found something that reflects my problem, but it is VBA (I think):
Const xlDown = -4121
Set objExcel = CreateObject(“Excel.Application”)
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Open(“C:\Scripts\Test.xls”)
Set objWorksheet = objWorkbook.Worksheets(1)
Set objRange = objExcel.Range(“A1”)
objRange.End(xlDown).Activate
intRow = objExcel.ActiveCell.Row
intColumn = objExcel.ActiveCell.Column
Set objRange = objWorksheet.Cells(intRow, intColumn).EntireRow
For i = 1 to 10
objRange.Insert(xlShiftDown)
Next
For i = 1 to 10
objExcel.Cells(intRow, 1).Value = i
intRow = intRow + 1
Next
strFormula = “=SUM(A1:A” & intRow – 1 & “)”
objExcel.Cells(intRow, 1).Formula = strFormula
Any way to make this work on a server in VBscript??? :-)
Since you can't do this using ADO (you'd just end up overwriting your formulae) you will need to directly access the workbook. The code you found is close but what's below should fit your needs. Let me know if you need any further explanation?
Option Explicit
Const xlDown = -4121
Const xlUp = -4162
Dim objExcel, objWorkbook, objRange, iLastRow, myRecordCount, numInserts, intLoop
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Open("C:\Scripts\Test.xls")
Set objWorksheet = objWorkbook.Worksheets(1) ' refers to first worksheet
iLastRow = objWorksheet.Cells(objWorksheet.Rows.Count, 1).End(xlUp).Row
Set objRange = objWorksheet.Cells(iLastRow, 1).EntireRow
' myRecordCount will need to hold the number of records you have
If myRecordCount > 34 Then
numInserts = myRecordCount - 34 ' get the number of rows to be inserted
Else
numInserts = 0
End If
For intLoop = 1 to numInserts
' for as many rows as we need, insert above the formula
objRange.Insert(xlShiftDown)
Next
' insert your data into the worksheet here
objWorkbook.Save
objWorkbook.Close
objExcel.Quit
' send the file out however you're sending it
Related
This question is about using content controls to move data values from Excel to Word in VBA. Please note I have enabled the "Microsoft Word 16.0 Object Library" under references in the MSExcel VBA environment.
My project needs to send Excel data to specific places in a Word document.
PROBLEM: It seems I am not using the contentcontrols properly and keep getting runtime errors I'm not finding much information about. Either RTE-438
Object doesen't support this method
or RTE-424
Object Required
Description of what the code does: There are two baseline workbooks with multiple worksheets. Another analysis workbook uses each of these is programmed with VLOOKUP(INDIRECT...),) to generate tables for reports put into a word document. A Variant is used to change the tabs being sourced in the baseline workbook. The analysis is basically CATS-DOGS=PETS. on each cycle through, tables that are not informational (no difference between two baseline workbooks) are skipped and the next tab is analyzed. If a table is informative, then a PDF is produced. The report (a Word document) is updated. Table is added to the report. Upon completion, the next tab or evaluation table is considered.
Sub CommandButton1_Click()
Dim Tabs(0 To 18) As Variant
Tabs(0) = "01"
Tabs(1) = "02"
Tabs(2) = "03"
Tabs(3) = "03"
Tabs(4) = "04"
Tabs(5) = "05"
Tabs(6) = "06"
Tabs(7) = "07"
Tabs(8) = "08"
Tabs(9) = "09"
Tabs(10) = "10"
Tabs(11) = "11"
Tabs(12) = "12"
Tabs(13) = "13"
Tabs(14) = "14"
Tabs(15) = "15"
Tabs(16) = "16"
Tabs(17) = "17"
Tabs(18) = "18"
Dim xlApp As Object
On Error Resume Next
Set xlApp = GetObject("excel.applicaiton")
If Err.Number = 429 Then
Err.Clear
Set xlApp = CreateObject("excel.applicaiton")
End If
On Error GoTo 0
Dim controlThis As String ' the controlThis variable is to the address of the particular data unit that should be passed to a word.documents.contentcontrols to update the text in the word document based on the change in the actual data.
Dim NetworkLocation As String
NetworkLocation = "\\myServer\myFolder\mySubfolder\"
Dim CATS As String
CATS = "kittens.xlsx"
Excel.Application.Workbooks.Open FileName:=(NetworkLocation & "Other Subforder\ThisWway\" & CATS)
Dim DOGS As String
DOGS = "puppies.xlsx"
Excel.Application.Workbooks.Open FileName:=(NetworkLocation & "differentSubfolder\ThatWay\" & DOGS)
'Populates the array with analysis tables
Dim Temples As Object
Dim Template(3 To 9) As Variant
Template(3) = "\3\EVAL Table 3.xlsx"
Template(4) = "\4\EVAL Table 4.xlsx"
Template(5) = "\5\EVAL Table 5.xlsx"
Template(6) = "\6\EVAL Table 6.xlsx"
Template(7) = "\7\EVAL Table 7.xlsx"
Template(8) = "\8\EVAL Table 8.xlsx"
Template(9) = "\9\EVAL Table 9.xlsx"
Dim strXLname As String
Dim opener As Variant
For Each opener In Template
strXLname = NetworkLocation & "Other Subfolder\EVAL Tables\WonderPets" & opener
Excel.Application.Workbooks.Open FileName:=strXLname
Dim currentDiffernce As Long
currentDifference = ActiveSheet.Cells(5, 6).Value
'This code cycles through the different EVAL Table templates
ActiveSheet.Cells(1, 1).Value = CATS
ActiveSheet.Cells(2, 1).Value = DOGS
Dim k As Variant
For Each k In Tabs
controlThis = k & "-" & eval 'passes a string to the wdApp.contentcontrol
ActiveSheet.Rows.Hidden = False
ActiveSheet.Cells(1, 4).Value = k 'initialize k
ActiveSheet.Calculate
DoEvents
currentDifference = ActiveSheet.Cells(5, 6).Value 'stop blank tables from being produced using the total delta in the preprogrammed spreadsheet
If currentDifference = 0 Then 'since the total difference in the current analysis is 0 this bit of code skips to the next WonderPet
Else
controlThis = k & "-" & opener '(Was eval as variant used with thisTable array)passes a string to the wdApp.contentcontrol
Call PDFcrate 'Print the Table to a PDF file. Worked well and was made a subroutine.
Dim objWord As Object
Dim ws As Worksheet
'Dim cc As Word.Application.ContentControls
Set ws = ActiveWorkbook.Sheets("Sheet1")
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open FileName:="myFilePath\Myfile.docx", noencodingdialog:=True ' change as needed
With objWord.ActiveDocument
.ContentControls(controlThis & " cats").Range.Text = eval.ActiveSheet.Cells(5, 4) 'These are the updates to the report for each content control with the title. Substituting SelectContentControlsByTitle() gives RTE-424 'Object Required'
.ContentControls(controlThis & " dogs").Range.Text = eval.ActiveSheet.Cells(5, 5)
.ContentControls(controlThis & " pets").Range.Text = eval.ActiveSheet.Cells(5, 6)
.ContentControls(controlThis & " Table).range. = 'Need to add the PDF to the report, perhaps using an RichTextConentConrols...additional suggestions welcomed (haven't researched it yet).
End With
Set objWord = Nothing
Word.Application.Documents.Close SaveChanges:=True 'Saves and Closes the document
Word.Application.Quit 'quits MS Word
End If
Next 'repeats for each tab with name "k" in the workbooks
Excel.Application.Workbooks(strXLname).Close
Next 'repeat for each evalTable
Excel.Application.Workbooks(CATS).Close
Excel.Application.Workbooks(DOGS).Close
End Sub
Word's content controls can't be picked up using a string as the index value the way other things can. The following line from the code sample in the question can't work:
.ContentControls(controlThis & " cats").Range.Text = eval.ActiveSheet.Cells(5, 4)
The only valid index value for a ContentControl is ID, which is a long number (GUID) assigned by the Word application when a ContentControl is generated.
The reason for this is that more than one content control can have the same Title (name) and/or Tag. Since this information is not unique it can't be used to pick up a single content control.
Instead, code needs to use either Document.SelectContentControlsByTitle or Document.SelectContentControlsByTag. These return an collection of content controls that meet the specified criterium. For example:
Dim cc as Word.ContentControls ' As Object if late-binding is used
With objWord.ActiveDocument
Set cc = .SelectContentControlsByTitle(controlThis & " cats")
'Now loop all the content controls in the collection to work with individual ones
End With
If it's certain there's only one content control with the Title, or only the first one is wanted, then it's possible to do this:
Dim cc as Word.ContentControl ' As Object if late-binding is used
With objWord.ActiveDocument
Set cc = .SelectContentControlsByTitle(controlThis & " cats").Item(1)
cc.Range.Text = eval.ActiveSheet.Cells(5, 4)
End With
Tip 1: Using ActiveDocument is not considered good practice for Word. As with ActiveCell (or anything else) in Excel, it's not certain that the "active" thing is the one that should be manipulated. More reliable is to use an object, which in this case can be assigned directly to the document being opened. Based on the code in the question:
Dim wdDoc as Object 'Word.Document
Set wdDoc = objWord.Documents.Open(FileName:="myFilePath\Myfile.docx", noencodingdialog:=True)
With wdDoc 'instead of objWord.ActiveDocument
Tip 2: Since the code in the question targets multiple content controls, rather than declaring multiple content control objects it might be more efficient to put the titles and values in an array and loop that.
This fixed it... looping through may have been the thing that got me unstuck.
The use of the plural ContentControls or singular ContentControl didn't seem to matter. My next trick is to get the tables into the word document... any thoughts?
Set wdDoc = Word.Application.Documents(wdDocReport)
Dim evalData(0 To 2) As Variant
evalData(0) = " CATS"
evalData(1) = " DOGS"
evalData(2) = " PETS"
Dim j As Variant
Dim i As Integer
i = 4
For Each j In evalData
Dim cc As Word.ContentControls
With Word.Application.Documents(wdDocReport)
.SelectContentControlsByTitle(controlThis & j).Item (1).Range.Text = ActiveWorkbook.ActiveSheet.Cells(5, i).Value
i = i + 1
End With
Next
Word.Application.Documents.Close SaveChanges:= True
Word.Application.Quit
Only one worksheet ever takes focus so the ActiveWorkbook and ActiveWorksheet didn't hurt me here
I'm new to VBA and am trying to cobble together some code to allow a user to input a word (or several words) into a cell and then show a list of matching row entries.
I have tried the following code but am getting an "instring = type mismatch" error.
Note that "B3" is the field dedicated for the "search word" and column F is the column containing the text I want to search within. If the word is contained, I want to show that row and hide all rows that don't contain that word.
Sub Find_Possible_Task()
ROW_NUMBER = 0
SEARCH_STRING = Sheets("codeset").Range("B3")
ROW_NUMBER = ROW_NUMBER + 1
ITEM_IN_REVIEW = Sheets("codeset").Range("F:F")
If InStr(ITEM_IN_REVIEW, SEARCH_STRING) Then
Do
Cells(c.Row).EntireRow.Hidden = False
Loop Until ITEM_IN_REVIEW = ""
End If
End Sub
TIA!
Few bad coding conventions or even possibly downright errors:
It's a good practice to explicity declare the scope Public/Private of your Sub procedure
Unless you're passing the variables from some place else, they need to be declared with Dim keyword
Using Option Explicit will help you prevent aforementioned error(s)
(Subjective) variables in all caps are ugly and in most programming languages it is convention to reserve all caps variables names for constants (Const)
Option Explicit
Private Sub keep_matches()
Dim what As Range
Dim where As Range
Dim res As Range ' result
Dim lr As Long ' last active row
Dim ws As Worksheet: Set ws = Sheets("codeset")
lr = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
Set what = ws.Range("B3")
Set where = ws.Range("F1:F" & lr)
' we'll create an extra column for a loop in our .Find method
where.Copy
ws.Range("F1").EntireColumn.Insert
ws.Range("F1").PasteSpecial xlPasteValues
where.EntireRow.Hidden = True ' preemptively hide them all
Set where = ws.Range("F1:F" & lr)
Set res = where.Find(what, lookIn:=xlValues) ' ilook for matches, 1st attempt
If Not res Is Nothing Then ' if found
Do Until res Is Nothing ' repeat for all results
res.EntireRow.Hidden = False
res = "Checked"
Set res = where.FindNext(res)
Loop
Else
MsgBox("No matches were found")
where.EntireRow.Hidden = False ' we don't wanna hide anything
End If
ws.Range("F1").EntireColumn.Delete ' remove the extra help column for Find method
End Sub
Should work as expected.
If there are any question, let me know.
instead of instr(), consider range.find().
Sub Find_Possible_Task()
Dim SEARCH_STRING As String
Dim ITEM_IN_REVIEW As Range
Dim found As Range
Dim i As Integer
SEARCH_STRING = Sheets("Sheet1").Range("B3").Value
i = 1
Do
Set ITEM_IN_REVIEW = Sheets("Sheet1").Cells(i, 6)
Set found = ITEM_IN_REVIEW.Find(What:=SEARCH_STRING)
If found Is Nothing Then
ITEM_IN_REVIEW.EntireRow.Hidden = True
End If
i = i + 1
Loop Until ITEM_IN_REVIEW = ""
End Sub
alternatively, consider using filter table:
1. check if your table has filter on ==> if yes, pass. if no, turn on filter.
2. filter column F for keyword to contain value in cell B3.
I'm trying to make a code in which to copy charts from a xls file into a word document using the PasteSpecial property (picture(enhanced metafile). I would like to change the existing charts of the document to new ones. So, I thought that using bookmarks for the existing charts would be OK. I'm using OFFICE 2007.
I've written the following code:
Dim YMApp As Word.Application
Dim YMDoc As Word.Document
Dim B as Bookmark
paaath = "D:\"
dime = "NameOld.doc"
dime2 = "NameNew.doc"
Set YMApp = New Word.Application
YMApp.Visible = True
Set YMDoc = YMApp.Documents.Open(paaath & dime)
Word.Documents(dime).SaveAs (paaath + dime2)
For k = 1 To 6
Windows("New.xls").Activate
Sheets("graph").Select
Range("L" + Trim(Str(br(k))) + ":V" + Trim(Str(br(k) + 24))).Select
Selection.Copy
ddd = "bm" + Trim(Str(k))
Set B = YMDoc.Bookmarks(ddd)
YMApp.Selection.PasteSpecial DataType:=wdPasteMetafilePicture, Placement:=B
Next k
YMDoc.Close
YMApp.Quit
Application.CutCopyMode = False
ActiveWorkbook.Close
End
End Sub
The problem is that by this code the bookmarks which are already created are not recognized. How to cope with the problem?
The Placement argument of PasteSpecial does not accept a Bookmark object:
Set B = YMDoc.Bookmarks(ddd)
YMApp.Selection.PasteSpecial DataType:=wdPasteMetafilePicture, Placement:=B
Instead, it takes a WdOLEPlacement constant.
I think you'll need to select the bookmark before you do the PasteSpecial. You may need to delete existing chart (if any), also.
Untested, but I think you need something like this:
Dim wdRange as Word.Range
Set B = YMDoc.Bookmarks(ddd)
Set wdRange = B.Range
YMApp.Selection.GoTo What:=wdGoToBookMark, Name:=B.Name
' Delete existing shapes & bookmark if any:
On Error Resume Next
YMDoc.ShapeRange(1).Delete
wdRange.Delete
On Error GoTo 0
YMApp.Selection.PasteSpecial DataType:=wdPasteMetafilePicture, Placement:=0 'Or 1
'Add the bookmark back in place:
MDoc.Selection.Bookmarks.Add Name:=ddd, wdRange
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 6 years ago.
Improve this question
I might have a question about VBA and Excel Macros. The thing that I need to do is to import data (actually integer values) from multiple text files that have random generated names (for example 12345678.txt, 8654321.txt, etc.) but which are stored in the same folder (let's call it Data folder) to excel into a column.
The problem that I face is that I have the same name for the measured values (called MVA) that are repeating over and over in the text files. I don't need all the data from the text files, only some specific rows of these MVA (for the example below let's say that I need only the MVA number for the "LED 01 Intensity" which is 6250 to be stored in a new cell in Excel. And I need to get that value that comes after "LED 01 Intensity" in the MVA row from 10 multiple text files (with random names that I don't know) to be stored each one in separate cells in Excel (from A1 to A10).
Example_____________________________________________________________________
Name: 153588.txt
Date: 14.05.2016
Name of product: Electronic Device 01
CHECK TEST
Resistance 101
MVA: 2 Ohm
MAX: 5 Ohm
MIN: 0 Ohm
PASS
LED 01 Intensity
MVA: 6250
MAX: 10000
MIN: 5000
PASS
I need a lot of these MVA values to be stored in Excel for analysis and I need to get an idea if this problem can be solved with VBA. If you can offer me some help to create a macro for this I would be thankful (I have basic knowledge of programming but I'm a beginner in VBA).
Here is the code I promised for. It is actually not only sample but actual code that you need according the descriptions you provided.
Please note I wrote it according to the sample file you provided - means that it might fail with different text file structures.
You will notice there is a settings section at the beginning. That's where you setup what needs to be given to the code.
It won't be a big impact for only hundreds of text files for your system considering the sample file - perhaps will work and finish in seconds. However screen updating might be disabled in the code during the code execution. See ScreenUpdating property of Excel Application object if you notice a real big system slowness.
I am hoping to give you some good start for the VBA, so I tried to use many methods and commented a lot to explain what we are doing in each step. For example, using the first worksheet as results worksheet in the newly created workbook but creating a new worksheet for the temporary worksheet. There is a reason for this: every new workbook is created with at least one worksheet but it might be also the only one worksheet according to the Excel settings in that computer. However, even those part could be designed different by getting the number of the worksheets first and delete the unnecessary ones and keep only 2 then use those instead creating a new one.
Shortly - there are many different ways to accomplish the same task - like in many other programming languages. For example, I used QueryTable to import data into the worksheet then used Find method to find out if it has the values I needed. I didn't have to do this, I could have instead put the all information in a string variable and make the search in the string! Or by using another method, or another.
Finally this is supposed to be what you need. And I hope it gives you a good start. To make this code work: Create a new workbook -> goto VBA -> Use menu and Insert->Module -> Copy and paste the following code into the right pane opened in the editor. Change the necessary variables in the settings area at the beginning in the sub procedure (likely only the path variable) and hit F5 to run the code.
Sub ImportData()
Dim wrk As Workbook
Dim shtSource As Worksheet
Dim shtResult As Worksheet
Dim rng As Range
Dim fndSection As Range
Dim fndValue As Range
Dim data As QueryTable
Dim strFile
Dim strPath As String
Dim strExt As String
Dim strSection As String
Dim strValue As String
' ======== BEGIN SETTINGS ========
' Define the files path - note there is a last backslash
strPath = "C:\Users\smozgur\Desktop\files\"
' Define file extension
strExt = "*.txt"
' Section to be find
strSection = "Led 01 Intensity"
' Cell value to be find after section
strValue = "MVA:"
' ======== END SETTINGS ========
' Create a new workbook to not mess with existing
Set wrk = Application.Workbooks.Add
With wrk
' Use first (or only) worksheet to store results
Set shtResult = .Worksheets(1)
' Create temp worksheet for reading text files
Set shtSource = .Worksheets.Add
End With
' Name the Results worksheet
' and put search value to indicate it in results
With shtResult
.Cells(1, 1).Value = strValue
.name = "Results"
End With
' Make file search with the given path & extension information
strFile = Dir(strPath & strExt, vbNormal)
' Dir function returns the first file name
' with the given extension in the given path
' if it is empty string then it means "no more file returned"
Do Until strFile = ""
' Create a query table buffer by using the file reference
' in the temp worksheet starting from cell A1
Set data = shtSource.QueryTables.Add(Connection:="TEXT;" & strPath & strFile, Destination:=shtSource.Cells(1, 1))
' Set up query table import properties
With data
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
' Finally retrieve data from the file
.Refresh BackgroundQuery:=False
End With
' Now the file content is in the temp worksheet as rows
' Find the section string in the data as Cell
Set fndSection = data.ResultRange.Find(strSection)
If Not fndSection Is Nothing Then
' If section is found then search for the Value Name AFTER found section
Set fndValue = data.ResultRange.Find(strValue, fndSection)
If Not fndValue Is Nothing Then
' If Value Name is found then put it into the next available cell in Results worksheet
' by removing the Value Name, so it will be the value itself
shtResult.Cells(shtResult.Rows.Count, 1).End(xlUp).Offset(1).Value = Replace(fndValue, strValue, "")
End If
End If
With data
' Clear the query table range
.ResultRange.Delete
' Delete the query table so we can recreate it for the next file
.Delete
End With
' Search for the next file meets the given path and extension criteria
strFile = Dir
Loop
' Delete the temporary worksheet
' Make it silent disabling Application Alerts about deleting the worksheet
Application.DisplayAlerts = False
shtSource.Delete
' Enable Application Alerts back
Application.DisplayAlerts = True
End Sub
Enjoy VBA programming!
==================================
* EDIT FOR MULTIPLE SECTIONS *
Following code handles multiple sections in the source files.
Sub ImportData()
Dim wrk As Workbook
Dim shtSource As Worksheet
Dim shtResult As Worksheet
Dim rng As Range
Dim fndSection As Range
Dim fndNextSection As Range
Dim fndValue As Range
Dim data As QueryTable
Dim strFile
Dim strPath As String
Dim strExt As String
Dim strSection As String
Dim strSections
Dim strValue As String
Dim i As Integer
Dim indFileNames As Boolean
' ======== BEGIN SETTINGS ========
' Define the files path - note there is a last backslash
strPath = "C:\Users\smozgur\Desktop\files\"
' Define file extension
strExt = "*.txt"
' Sections to be find
strSections = Array("Led 01 Intensity", _
"Led 02 Intensity", _
"Led 03 Intensity", _
"Led 04 Intensity", _
"Led 05 Intensity")
' Cell value to be find after section
strValue = "MVA:"
' Indicate file names in the output?
indFileNames = True
' ======== END SETTINGS ========
' Create a new workbook to not mess with existing
Set wrk = Application.Workbooks.Add
With wrk
' Use first (or only) worksheet to store results
Set shtResult = .Worksheets(1)
' Create temp worksheet for reading text files
Set shtSource = .Worksheets.Add
End With
' Name the Results worksheet
' and put section headers to indicate their columns
With shtResult
With .Cells(1).Resize(, UBound(strSections) + 1)
.Value = strSections
.Resize(, UBound(strSections) + 1).Font.Bold = True
End With
If indFileNames = True Then
With .Cells(1, UBound(strSections) + 3)
.Value = "NOTES"
.Font.Bold = True
End With
End If
.name = "Results"
End With
' Make file search with given information
strFile = Dir(strPath & strExt, vbNormal)
' Dir function returns the first file name
' with the given extension in the given path
' if it is empty string then it means "no more file returned"
Do Until strFile = ""
' Create a query table buffer by using the file reference
' in the temp worksheet starting from cell A1
Set data = shtSource.QueryTables.Add(Connection:="TEXT;" & strPath & strFile, Destination:=shtSource.Cells(1, 1))
' Set up query table import properties
With data
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
' Finally retrieve data from the file
.Refresh BackgroundQuery:=False
End With
' Now the file content is in the temp worksheet as rows
' Loop through requested sections
For i = 0 To UBound(strSections)
' Find the section string in the data as Cell
Set fndSection = data.ResultRange.Find(strSections(i))
If Not fndSection Is Nothing Then
' If section is found then search for the Value Name AFTER found section
Set fndValue = data.ResultRange.Find(strValue, fndSection)
If Not fndValue Is Nothing Then
' What if value doesn't exist in this section but it finds the next value in the next section
' We have to avoid that unless we are certainly sure each section MUST have the value
If i < UBound(strSections) Then
Set fndNextSection = data.ResultRange.Find(strSections(i + 1), fndSection)
Else
Set fndNextSection = shtSource.Cells(shtSource.Rows.Count)
End If
' Next available cell in the Results worksheet
Set rng = shtResult.Cells(shtResult.Rows.Count, i + 1).End(xlUp).Offset(1)
' Only use the value if found value belongs to the section
If fndValue.Row < fndNextSection.Row Then
' If Value Name is found then put it into the next available cell in Results worksheet
' by removing the Value Name, so it will be the value itself
rng.Value = Replace(fndValue, strValue, "")
Else
rng.Value = "N/A"
End If
End If
End If
Next i
If indFileNames = True Then
' Let's indicate which file we got this values
Set rng = shtResult.Cells(shtResult.Rows.Count, UBound(strSections) + 3).End(xlUp).Offset(1)
rng.Value = strFile
End If
With data
' Clear the query table range
.ResultRange.Delete
' Delete the query table so we can recreate it for the next file
.Delete
End With
' Search for the next file meets the given path and extension criteria
strFile = Dir
Loop
' Autofit columns in the Results worksheet
shtResult.Columns.AutoFit
' Delete the temporary worksheet
' Make it silent disabling Application Alerts about deleting the worksheet
Application.DisplayAlerts = False
shtSource.Delete
' Enable Application Alerts back
Application.DisplayAlerts = True
End Sub
I'm trying to write the last part of my program and I need to pull data from an Access document and print it into a new Workbook.
To start, I will be taking the names of product Suppliers and creating a Worksheet with each suppliers name, then I want to be looping through each sheet and printing the products from each supplier that were ordered.
I'm really struggling with wrapping my head around how to open a new workbook and print in my info.
As my previous answer was deleted (considered "insuficient"), I have to provide a better one.
If you want to output data from Access to Excel, you have to follow this steps:
Create (or open) a new workbook
Read your data
Write your data to the workbook
Format the data in the workbook
I will focus on the data output, and leave the formatting out (the data part is the complicated one... formatting is easy)
First, you need to enable the Excel objects in your Access file: Tools Menu > References. Find the Microsoft Excel 12.0 Object Library and activate the checkbox. Now you have the full Excel library at your service :-)
Now is the time for the data crunching. I will asume that you need to create a new workbook:
public sub createExcelFile()
dim XL as Excel.Application, WB as Excel.Workbook, WKS as Excel.Worksheet
dim db as DAO.database, rec as DAO.recordset, f as DAO.field
dim i as integer, j as integer
' Prepare your Excel stuff
Set XL = new Excel.Application
XL.Visible = True
Set WB = XL.Workbooks.Add
WB.Activate
Set WKS = WB.ActiveSheet ' Default: The first sheet in the newly created book
' Read your data here
set db = currentdb()
set rec = db.openrecordset("tblSampleData")
' A simple table that will show the data from rec
' i and j will be the coordiantes of the active cell in your worksheet
with rec
.movefirst
' The table headers
i = 1
j = 1
for each f in .fields
WKS.cells(i,j).value = f.name
j = j + 1
next f
' The table data
do
i = i+1
j = 1
for each f in .Fields
WKS.cells(i,j).value = f.value
j = j+1
next f
.moveNext
loop until .EOF
end with
end sub
If you want to format the cells, you can use the WKS.cells(i,j) (or WKS.range(...)) properties.
Take a look at the link I leaved before (which Siddarth Rout was kind to move to the comments).
I hope this helps you
Option Compare Database
Public Function format(filepath, sheetname)
Set xls = CreateObject("EXCEL.APPLICATION")
xls.screenupdating = False
xls.displayalerts = False
xls.Visible = True
xls.workbooks.Open filepath
Set xlsdd = xls.ActiveWorkbook
'deleting headers
xls.Range("1:1").Select
xls.Selection.Delete Shift:=xlUp
'adding one column
xls.Columns("A:A").Select
xls.Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'adding 5 rows
'ActiveWorkbook.Sheets("sheet1").Select
xls.Rows("1:5").Insert Shift:=xlDown
'fetching rows from access and putting them into excel
strsql = "select top 5 " & sheetname & ".* into top5_records from " & sheetname
DoCmd.RunSQL strsql
outputFileName = "C:\Users\hp\Desktop\top5_records.xls"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "top5_records", outputFileName, True
'then open that excel and copy the rows
Set xls2 = CreateObject("EXCEL.APPLICATION")
xls2.screenupdating = False
xls2.displayalerts = False
xls2.Visible = True
xls2.workbooks.Open outputFileName
Set xlsdd2 = xls.ActiveWorkbook
xls2.Rows("1:5").Select
xls2.Selection.Copy
xls.Cells(1, 1).Select
xls.activesheet.Paste
' Dim currdb As DAO.Database
' Dim rst As DAO.Recordset
'
' Set currdb = CurrentDb
' Set rst = currdb.OpenRecordset(strsql) '<<<Opens query recordset via DAO
' rst.MoveLast
' rowsToReturn = rst.RecordCount
' Set rng = xls.Cells(1, 1)
' 'copy specified number of records to worksheet
'
'rng.CopyFromRecordset rst, rowsToReturn '<<<Gets all records in recordset
'making first 6th row to be bold
xls.Rows("6:6").Select
With xls.Selection.Font
.Bold = True
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
End With
'autofit the data
xls.Sheets(sheetname).Cells.Columns.autofit
xls.CutCopyMode = False
With xlsdd
.Save
.Close
End With
xls.Visible = False
Set xlsdd = Nothing
Set xls = Nothing
End Function
You can define column/row widths to a static pixel amount or auto-fit, things like bold are a pre-defined
Example Selection.Font.Bold = True
You can also make a template spreadsheet, copy the contents into the template and save as.
Your post does not indicate how much formatting actually needs to be done.
You don't give a lot of details, so I can't give you a lot of details in return. But here's how I would do it:
Create a new workbook manually with two sheets
On one sheet, add an External Data table that returns a list of supplier's name like SELECT SupplierName FROM tblSuppliers WHERE Active=True; or something like that.
Create a workbook-level named range that dynamically expands with that query table
On the second sheet, add an External Data table like SELECT * FROM Orders WHERE SupplierName=? (This will be a parameter query). Start that external data table in row 3
I row, put a combobox box that points back to the supplier list.
Now the VBA is simple
ThisWorkbook.RefreshAll
Instead of one sheet per supplier, you'll have one sheet on which you can change the supplier. Here are the skills you'll need
Create an external data table
Create a parameter query (old reference http://www.dicks-clicks.com/excel/ExternalData6.htm)
Create dynamically expanding range name
Add a combobox or data validation that points to a range on a different sheet
That SQL above is obviously not right, but I assume you can write the correct SQL statement
You should be able to find details on all that, but if not, post another question.