I'm trying to insert a column to an Excel spreadsheet via a script. I found the code below which should allow me to insert a column, but how would I then go about filling that column with data like I would in the Excel application using the fill>down or fill>series commands?
Const xlToRight = -4161
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWB = objExcel.Workbooks.Open("C:\Temp\Scripts\Test2.xls")
Set objSheet = objwb.Sheets("Overall")
objSheet.Columns("D:D").Insert xlToRight
objWB.Close True
objExcel.Quit
EDIT
Here's what ended up working.
Const xlToRight = -4161
const xlColumns = &H2
const xlLinear = -4132
const xlDay = 1
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWB = objExcel.Workbooks.Open("C:\Temp\Scripts\Test2.xls")
Set objSheet = objwb.Sheets("Overall")
objSheet.Columns("A:A").Insert xlToRight
objSheet.Cells(1, 1).Value = "label"
objSheet.Cells(2, 1).Value = "Value"
set Range = objSheet.Range("A2:A"&objSheet.UsedRange.Rows.Count)
Range.FillDown
objSheet.Columns("A:A").Insert xlToRight
objSheet.Cells(1, 1).Value = "series"
objSheet.Cells(2, 1).Value = 1
set Range = objSheet.Range("A2:A"&objSheet.UsedRange.Rows.Count)
Range.DataSeries xlColumns, xlLinear,xlDay, 1, , False
objWB.Close True
objExcel.Quit
How To Insert a value into a Cell
The syntax (the object model) of using vbscript seems to be quite similar to excel VBA Macros.
objSheet.Cells(2,4).Value = "foo"
If you have any trouble finding something out it may work to create an excel macro using the built in macro recorder and take a look at the generated vba code - this helped me in the past to better understand excel vba macros. I assume that the vba code can be used in vbscript as well.
Related
I have written some code that plugs excel formulas exctracted from one file and stored in a db into a new excel file. Unfortunately those forumlas do not activate after being inserted and thus I receive an error when trying to import the value of those cells back into access. I tried to force calculation in excel using:
xlApp.Calculate
xlSheet.Calculate
xlApp.CalculateFull
xlApp.CalculateFullRebuild
which has no effect. It also does not work when using the button on the excel ribbon itself. I have also tried to set the cell format manually using:
xlSheet.Range(rstZutaten!XLCell).Offset(0, 1).NumberFormat = "0.0000"
Which has also not worked. The formula string inserts just fine into the excel file, it just doesnt activate and calculate the value of the cell. I can activate the cells by clicking on them and pressing enter etc. manually in the file but I want to do that in vba instead. Not sure where exactly the error is so I would appreciate any help. The code is quite long. The error occurs at
rsRes!Wert = xlSheet.Range("F" & i).Value
Here the full code:
Private Sub Befehl8_Click()
'Declare variables
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rsRes As DAO.recordset 'rs of temp table (Output)
Dim rsZwi As DAO.recordset 'rs of temp table (Zwischenwerte)
Dim rsRec As DAO.recordset 'rs clone of subform Rechenwerte
Dim rstRechenwerte As DAO.recordset
Dim rstZwischenwerte As DAO.recordset
Dim rstZutaten As DAO.recordset
Dim RezeptID As Integer
Dim RechengruppeID As Integer
Dim i As Integer
'Set Current Rezept and Rechengruppe
RezeptID = Me.RezeptID
RechengruppeID = Me.RechengruppeID
'Initialize variables
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Add
Set xlSheet = xlWB.Sheets("Tabelle1") 'Set xlSheet to the first sheet in the workbook
Set rsRes = CurrentDb.OpenRecordset("tblTempResults", dbOpenDynaset)
Set rsZwi = CurrentDb.OpenRecordset("tblTempZwischenwerte", dbOpenDynaset)
Set rsRec = Me.frmSubRechenwerteBox.Form.recordset.Clone
'Disable user input
Call mdlMiscFunctions.DisableKeyboardMouse(True)
'Clear temporary data tables for Results and Zwischenwerte
If Not rsRes.EOF Then Call ClearTableOnClose("tblTempResults")
If Not rsZwi.EOF Then Call ClearTableOnClose("tblTempZwischenwerte")
'Prevent prompt to save changes to excel
xlApp.DisplayAlerts = False
xlApp.Visible = True
' Open the Recordset for tblRechenwerte
Set rstRechenwerte = CurrentDb.OpenRecordset("SELECT Rechenwert, WertBezeichnung, XLCell FROM tblRechenwerte WHERE RechengruppeID = " & RechengruppeID)
' Insert the values of "Rechenwert" in the cells specified by "XLCell"
rstRechenwerte.MoveFirst
Do Until rstRechenwerte.EOF
xlSheet.Range(rstRechenwerte!XLCell).Value = rstRechenwerte!WertBezeichnung
xlSheet.Range(rstRechenwerte!XLCell).Offset(0, 1).Value = rstRechenwerte!Rechenwert
xlSheet.Range(rstRechenwerte!XLCell).Offset(0, 1).NumberFormat = "0.0000"
rstRechenwerte.MoveNext
Loop
xlApp.Calculate
xlSheet.Calculate
xlApp.CalculateFull
xlApp.CalculateFullRebuild
rstRechenwerte.Close
' Open the Recordset for tblZwischenwerte
Set rstZwischenwerte = CurrentDb.OpenRecordset("SELECT ZWBezeichnung, XLFormula, XLCell FROM tblZwischenwerte WHERE RezeptID = " & RezeptID)
' Insert the values of "ZWBezeichnung" in the cells specified by "XLCell"
rstZwischenwerte.MoveFirst
Do Until rstZwischenwerte.EOF
xlSheet.Range(rstZwischenwerte!XLCell).Value = rstZwischenwerte!ZWBezeichnung
xlSheet.Range(rstZwischenwerte!XLCell).Offset(0, 1).Formula = rstZwischenwerte!xlFormula
xlSheet.Range(rstZwischenwerte!XLCell).Offset(0, 1).NumberFormat = "0.0000"
rstZwischenwerte.MoveNext
Loop
xlApp.Calculate
xlSheet.Calculate
xlApp.CalculateFull
xlApp.CalculateFullRebuild
rstZwischenwerte.Close
' Open the Recordset for tblZutaten
Set rstZutaten = CurrentDb.OpenRecordset("SELECT Zutat, XLFormula, XLCell FROM tblZutaten WHERE RezeptID = " & RezeptID)
' Insert the values of "Zutat" in the cells specified by "XLCell"
rstZutaten.MoveFirst
Do Until rstZutaten.EOF
xlSheet.Range(rstZutaten!XLCell).Value = rstZutaten!Zutat
xlSheet.Range(rstZutaten!XLCell).Offset(0, 1).Formula = rstZutaten!xlFormula
xlSheet.Range(rstZutaten!XLCell).Offset(0, 1).NumberFormat = "0.0000"
rstZutaten.MoveNext
Loop
xlApp.Calculate
xlSheet.Calculate
xlApp.CalculateFull
xlApp.CalculateFullRebuild
rstZutaten.Close
'Extract data from excel and insert into tblTempResults
i = 4
Do Until IsEmpty(xlSheet.Range("E" & i).Value)
rsRes.AddNew
rsRes!RezepturKomponenten = xlSheet.Range("E" & i).Value
rsRes!Wert = xlSheet.Range("F" & i).Value
rsRes.Update
i = i + 1
Loop
'Extract data from exel and insert into tblTempZwischenwerte
i = 4
Do Until IsEmpty(xlSheet.Range("C" & i).Value)
rsZwi.AddNew
rsZwi!Zwischenwert = xlSheet.Range("C" & i).Value
rsZwi!Wert = xlSheet.Range("D" & i).Value
rsZwi.Update
i = i + 1
Loop
'Clean up and close excel
rsRes.Close
rsRec.Close
rsZwi.Close
xlWB.Close SaveChanges:=False
xlApp.Quit
'Release objects from memory
Set xlSheet = Nothing
Set xlWB = Nothing
Set xlApp = Nothing
Set rsRes = Nothing
Set rsZwi = Nothing
Set rsRec = Nothing
Set rstRechenwerte = Nothing
Set rstRechenwerte = Nothing
Set rstZutaten = Nothing
'Refresh the main Form frmClacBatch
DoCmd.RunCommand acCmdRefresh
'Enable user input
Call mdlMiscFunctions.DisableKeyboardMouse(False)
End Sub
I still have to clean up the code so its still a work in progress, but most of it should work even if it could probably be simplified a bit.
Some info on the formats:
I am always opening a new excel workbook to insert the formulas so all cells are formatted as "standard" by default. I tried setting the format manually before AND after plugging in the formula like so:
rstZutaten.MoveFirst
Do Until rstZutaten.EOF
xlSheet.Range(rstZutaten!XLCell).Value = rstZutaten!Zutat
xlSheet.Range(rstZutaten!XLCell).Offset(0, 1).NumberFormat = "General"
xlSheet.Range(rstZutaten!XLCell).Offset(0, 1).Formula = rstZutaten!xlFormula
rstZutaten.MoveNext
Loop
I tried using "General" and some other formats like "0,000" etc. None have any effect.
The excel file itself after inserting the formulas looks something like this:
The formulas are correct and if I select the cell, click on the formula bar and hit enter, they calculate the value correctly and display that instead. Calculations are set to automatic as per default. I read that there might be issues if the formulas are not in english so I converted them to the english expression like =SUM(A3,B3:F12)instead of =SUMME(A3;B3:F12). That did not fix the issue either. The cells I plug the formulas into and the ones I try to extract the values from are correctly specified and are in fact the same cells.
I am having a very strange problem with this code. The general purpose is to save user data from a form in Access to a spreadsheet in Excel, and then use an email client to send an email containing the spreadsheet attachment. The code is as follows
Private Sub Send_Email_Click()
Dim MySheetPath As String
Dim Xl As Excel.Application
Dim XlBook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
' Tell it location of actual Excel file
MySheetPath = "\\SERVER\Users\Public\Documents\WORK ORDERS\Blank Work Order.xlsx"
'Open Excel and the workbook
Set Xl = CreateObject("Excel.Application")
Set XlBook = GetObject(MySheetPath)
'Make sure excel is visible on the screen
Xl.Visible = True
XlBook.Windows(1).Visible = True
'Define the sheet in the Workbook as XlSheet
Set XlSheet = XlBook.Worksheets(1)
'Insert values in the excel sheet starting at specified cell
XlSheet.Range("B6") = Jobnameonform.Value
XlSheet.Range("C7") = Companynameonform.Value
XlSheet.Range("C8") = Employeename.Value
XlSheet.Range("H7") = Jobnumberonform.Value
Xl.ActiveWorkbook.Save
Xl.ActiveWorkbook.Close
Xl.Quit
'in case something goes wrong
Set Xl = Nothing
Set XlBook = Nothing
Set XlSheet = Nothing
Dim cdomsg
Set cdomsg = CreateObject("CDO.message")
With cdomsg.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'NTLM method
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = 587
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "matthewfeeney6#gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "REDACTED"
.Update
End With
' build email parts
With cdomsg
.To = "matthewfeeney6#gmail.com"
.From = "matthewfeeney6#gmail.com"
.Subject = "Test email"
.TextBody = "Did you get the attachment?"
.AddAttachment "\\SERVER\Users\Public\Documents\WORK ORDERS\Blank Work Order.xlsx"
.Send
End With
Set cdomsg = Nothing
MsgBox "Completed"
End Sub
Without the line ".AddAttachment..." The code works exactly as intended, minus sending the attachment of course. However, with that line, I get a runtime error 91, with the debugger citing the line "Xl.ActiveWorkbook.Save" as the problematic code. Also, without the code to modify the excel spreadsheet, the simple email portion does work, attachments included. If anyone can provide insight as to why I am getting this error, that would be very helpful. Thanks in advance!
EDIT: Retesting the code, it seems to consistently crash at Xl.ActiveWorkbook.Save I thought it worked before, but I must have been mistaken
You (think you) are saving and closing your workbook with:
Xl.ActiveWorkbook.Save
Xl.ActiveWorkbook.Close
but that's not the workbook you're using and manipulating, which is XlBook:
Set XlBook = GetObject(MySheetPath)
If you save and close the "real" workbook, XlBook:
XlBook.Save
XlBook.Close
then it should work.
The reason you're getting the error at the Save call probably means that the Xl.ActiveWorkbook object doesn't exist/is null or something.
I want to copy a specific column from the excel files located in a folder and paste all the values in a new excel sheet.
Completed-
I am able to loop through all the files located in a folder.
I am able to copy the data from specific column.
Not able to complete:
Not able able to paste the copied data.
I want to copy only the distinct values.
I want to copy columns till the rows are there. like if there are 7
rows then copy 7 values of column. My copy command is copying all
the values up to last row of excel sheet.
My code (VBScipt)-
strPath="C:\Test"
Set objExcel= CreateObject("Excel.Application")
objExcel.Visible= True
Set objExcel2= CreateObject("Excel.Application")
objExcel2.Visible= True
objExcel2.Workbooks.open("C:\Test\New Folder\4.xlsx")
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder (strPath)
For Each objFile In objFolder.Files
If objFso.GetExtensionName(objFile.Path) = "xlsx" Then
objExcel.Workbooks.Open(objFile.Path)
Set Source=objExcel.Activeworkbook.Sheets(1).Columns("G")
Source.Copy
Set dest=objExcel2.Activeworkbook.Sheets(1).Columns("A")
dest.Paste
objExcel.Activeworkbook.save
objExcel.Activeworkbook.close
objExcel2.Activeworkbook.save
objExcel2.Activeworkbook.close
End If
Next
This function will return the used range for a given column on a worksheet.
Private Function getRange(ByVal ColumnName As String, ByVal Sheet As Worksheet) As Range
Set getRange = Sheet.Range(ColumnName & "1", ColumnName & Sheet.Range(ColumnName & Sheet.Columns(ColumnName).Rows.Count).End(xlUp).Row)
End Function
If you use this in-place of your Set Source=objExcel.Activeworkbook.Sheets(1).Columns("G") it should do what you want.
eg: Set Source = getRange("G", objExcel.Activeworkbook.Sheets(1))
You might need to change your dest to a cell instead of the column (in-case excel moans about it being the wrong size)
Set dest = objExcel.Activeworkbook.Sheets(1).Cells("A1")
Just saw that you tagged it as VBScript, I haven't tested it as VBS but it might work just the same as VBA.
For distinct copying .AdvancedFilter() method used, cells defined with getRange() from #NickSlash. For data addition from files, new sheet is created for each of them, and then data is filtered to it. I hope this helps.VBScript
Const xlFilterCopy = 2
Const xlUp = -4162
Const xlDown = -4121
strPathSrc = "C:\Test" ' Source files folder
strMaskSrc = "*.xlsx" ' Source files filter mask
iSheetSrc = 1 ' Sourse sheet index or name
iColSrc = 7 ' Source column index, e. g. 7 for "G"
strPathDst = "C:\Test\New Folder\4.xlsx" ' Destination file
iColDst = 1 ' Destination column index
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkBookDst = objExcel.Workbooks.Open(strPathDst)
Set objSheetTmp = objWorkBookDst.Worksheets.Add
objSheetTmp.Cells(1, iColDst).Value = "TempHeader"
Set objShellApp = CreateObject("Shell.Application")
Set objFolder = objShellApp.NameSpace(strPathSrc)
Set objItems = objFolder.Items()
objItems.Filter 64 + 128, strMaskSrc
objExcel.DisplayAlerts = False
For Each objItem In objItems
Set objWorkBookSrc = objExcel.Workbooks.Open(objItem.Path)
Set objSheetSrc = objWorkBookSrc.Sheets(iSheetSrc)
objSheetSrc.Cells(1, iColSrc).Insert xlDown
objSheetSrc.Cells(1, iColSrc).Value = "TempHeader"
Set objRangeSrc = GetRange(iColSrc, objSheetSrc)
If objRangeSrc.Cells.Count > 1 then
nNextRow = GetRange(iColDst, objSheetTmp).Rows.Count + 1
objRangeSrc.AdvancedFilter xlFilterCopy, , objSheetTmp.Cells(nNextRow, iColDst), True
objSheetTmp.Cells(nNextRow, iColDst).Delete xlUp
Set objRangeTmp = GetRange(iColDst, objSheetTmp)
Set objSheetDst = objWorkBookDst.Worksheets.Add
objRangeTmp.AdvancedFilter xlFilterCopy, , objSheetDst.Cells(1, iColDst), True
objSheetTmp.Delete
Set objSheetTmp = objSheetDst
End If
objWorkBookSrc.Close
Next
objSheetTmp.Cells(1, iColDst).Delete xlUp
objExcel.DisplayAlerts = True
Function GetRange(iColumn, objSheet)
With objSheet
Set GetRange = .Range(.Cells(1, iColumn), .Cells(.Cells(.Cells.Rows.Count, iColumn).End(xlUp).Row, iColumn))
End With
End Function
I think PasteSpecial will help with the pasting in vb script. It is best to use the -4163 argument in PasteSpecial to ensure that only the values are pasted. The code below worked for me in Microsoft Visual Studio 2012. Added comments just to know where the program is in the code. Hope this helps.
Imports System.Data.OleDb
Imports System.IO
Imports System.Text
Public Class Form1
Dim objCSV, objExcel, objSourceWorkbook, objDestWorkbook, objCSVWorkSheet, objXLSWorkSheet, srcCPUXrange, srcCPUYrange, srcMEMYrange, dstCPUXrange, dstCPUYrange, dstMEMYRange
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
'Create and open source CSV object
Label1.Text = "Setting Source"
objCSV = CreateObject("Excel.Application")
objCSV.Visible = True
objSourceWorkbook = objCSV.Workbooks.Open("C:\SourceFile.csv")
Label1.Text = "Source set"
'Create and open destination Excel object
Label1.Text = "Setting Destination"
objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objDestWorkbook = objExcel.Workbooks.Open("C:\DestinationFile.xlsx")
Label1.Text = "Destination Set"
'Select desired range from CSV file
Label1.Text = "Copying Data"
objCSVWorkSheet = objSourceWorkbook.Worksheets(1)
objCSVWorkSheet.Activate()
objSourceWorkbook.Worksheets(1).Range("A1").EntireColumn.Copy()
Label1.Text = "Data Copied"
'Paste in Excel workbook
Label1.Text = "Pasting Data"
objXLSWorkSheet = objDestWorkbook.Worksheets(1)
objXLSWorkSheet.Activate()
objDestWorkbook.Worksheets(1).Range("A2").PasteSpecial(-4163)
Label1.Text = "Data Pasted"
End Sub
End Class
I am having a rough time getting this VBscript line to work with the excel object:
set fso=CreateObject("Scripting.FileSystemObject")
Set WShell = CreateObject("WScript.Shell")
Set objExcel = createobject("Excel.application")
objexcel.Visible = true
objexcel.Application.ScreenUpdating = True
objexcel.Workbooks.Open dir & masterFileName
objexcel.Activeworkbook.Worksheets("xActive_User_Ratio").Activate
objexcel.Range("A1").Select
objexcel.Range(Selection, Selection.End(xlToRight)).Select
when I run this code I get an error:
Object required: 'Selection'
What am I doing wrong? Any example would be very much helpful.
Please Help
It's because you are running this from outside Excel.
Use objExcel.Selection instead of just Selection. So that your code knows that Selection is associated with the Excel Application. Additionally, you'll need to define xlToRight or replace it with it's numerical value.
Better yet, I'd use with and rewrite the whole thing like so:
Set fso = CreateObject("Scripting.FileSystemObject")
Set WShell = CreateObject("WScript.Shell")
Set objexcel = CreateObject("Excel.application")
xlToRight = -4161 ' -4161 is the value of xlToRight
With objexcel
.Visible = True
.Application.ScreenUpdating = True
'using variables for workbook and worksheet to be explicit
Set wb = .Workbooks.Open(Dir & masterFileName)
Set ws = wb.Worksheets("xActive_User_Ratio")
ws.Activate
ws.Range("A1").Select
ws.Range(.Selection, .Selection.End(xlToRight)).Select
End With
I have an Excel spreadsheet that I have exported from some other program.
It has rows that are colored based on few business conditions.
Now I have to transpose the whole excel sheet along with the colors and formatting.
Please note that I have to do this using Vbscript only.
This is the code I've written so far, but this transposes without the formatting:
sub transpose
On Error Resume Next
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.Workbooks.Add()
set table = ActiveDocument.GetSheetObject( "CH01" )
CellRect = ActiveDocument.GetApplication().GetEmptyRect()
CellRect.Top = 0
CellRect.Left = 0
CellRect.Width = table.GetColumnCount
CellRect.Height = table.GetRowCount
set CellMatrix = table.GetCells( CellRect )
for RowIter=CellRect.Top to CellRect.Width-1
for ColIter=CellRect.Left to CellRect.Height-1
ObjExcel.Cells(RowIter+1, ColIter+1).Value = CellMatrix(ColIter)(RowIter).Text
'msgbox(CellMatrix(ColIter)(RowIter).Text)
next
next
objExcel.ActiveWorkbook.SaveAs("C:\Documents and Settings\prasanna\Desktop\test3.xls")
objExcel.Application.Workbooks.Open("C:\Documents and Settings\prasanna\Desktop\test3.xls")
objExcel.Application.Visible = True
objExcel = Nothing
end sub
Phew.., this costed some time and experimenting, here a working solution for office 2012
const xlPasteValuesAndNumberFormats = 12 'doesn't work with Excel 2010 ?
const xlFormats =-4122
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.DisplayAlerts = false
if you allready have your target xls you can skip these lines
Set wbkDest = objExcel.Workbooks.Add
wbkDest.saveAs "c:\test2.xls"
wbkDest.close
and go on here
Set objWorkbook1= objExcel.Workbooks.Open("C:\test1.xls")
Set objWorkbook2= objExcel.Workbooks.Open("C:\test2.xls")
objWorkbook1.Worksheets("Sheet1").UsedRange.Copy
'we have to do the paste twice, once for the values, once for the formats
objWorkbook2.Worksheets("Sheet1").Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
objWorkbook2.Worksheets("Sheet1").Range("A1").PasteSpecial xlFormats
objWorkbook1.save
objWorkbook2.save
objWorkbook1.close
objWorkbook2.close
set objExcel=nothing