I'm trying to fill formulas in excel sheet from access db VBA.I referred this
Here is my code
Dim xlApp As Excel.Application
Dim wb As Workbook
Dim strFormulas(1 To 4) As Variant
txtcatpath = Form_Bom.Excelpath.Value
Set xlApp = CreateObject("Excel.Application")
With xlApp
Set wb = .Workbooks.Open(txtcatpath)
.Visible = True
End With
With wb.Sheets("common based")
strFormulas(1) = "=IF(F4<>F5,E4,E4&""&H5)"
strFormulas(2) = "=VLOOKUP(J4,F:H,3,FALSE)"
strFormulas(3) = "=IF(COUNTIF(F4:F900,F4)=1,F4,"")"
strFormulas(4) = "=SUMIF(F:F,J4,G:G)"
.Range("H4:K4").Formula = strFormulas
.Range("H4:K" & LRow & "").FillDown
End With
When debugging my code is getting broken in .Range("H4:K4").Formula = strFormulas. How do i fill the columns with the formula.
Related
I want to create a pivot table with Access 2003 into Excel. Now I can create a pivot table but background process excel is not close. Results my program can run only once time.
I want to know how to close Excel background process.
My code:
Dim lRET As Integer
Dim lEXCEL_OBJ As Excel.Application
Dim lWKB As Excel.Workbook
Dim lSHEET As Excel.Worksheet
Dim lSHEET2 As Excel.Worksheet
Dim lFILEFULLNAME As String
Dim lTEMPLATEFILE As String
Dim lTEMPLATEPATH As String
Dim lBUTTON As String
Dim PTcache As Excel.PivotCache
Dim PT As Excel.PivotTable
Dim PRange As Range
Dim LastRow As Long
Dim LastCol As Long
Const lFILE As String = "template_macro2.xlt"
On Error GoTo EXCEL_RESULT_T_ERROR
lTEMPLATEPATH = "C:\Temp\" & lFILE
lTEMPLATEFILE = Dir(lTEMPLATEPATH)
Set lEXCEL_OBJ = CreateObject("Excel.Application")
Set lWKB = lEXCEL_OBJ.Workbooks.Add(lTEMPLATEPATH)
With lEXCEL_OBJ
Set lWKB = .Workbooks.Add(lTEMPLATEPATH)
Set lSHEET = .ActiveWorkbook.Sheets(1)
End With
With lEXCEL_OBJ
lWKB.Worksheets.Add
lWKB.ActiveSheet.Name = "test1"
Set lSHEET = .ActiveSheet
End With
With lSHEET
.Range("a:z").ColumnWidth = 10
.Range("b:b").ColumnWidth = 22
.Range("m:m").ColumnWidth = 24
.Range("q:q").ColumnWidth = 50
.Range("u:u").ColumnWidth = 15
End With
'add raw data in excel
Call MAKE_EXPORT_TABLE_DO_OR(lSHEET)
With lEXCEL_OBJ
lWKB.Sheets("Sheet1").Select
lWKB.Worksheets.Add
lWKB.ActiveSheet.Name = "test2"
Set lSHEET2 = .ActiveSheet
'Define Data Range
LastRow = lSHEET.Cells(lSHEET.Rows.COUNT, 1).End(-4162).Row
LastCol = lSHEET.Cells(1, lSHEET.Columns.COUNT).End(-4159).Column
Set PRange = lSHEET.Cells(1, 1).Resize(LastRow, LastCol)
'Create a Pivot Cache
Set PTcache = ActiveWorkbook.PivotCaches.Add(xlDatabase, PRange)
'Create the Pivot Table from the Cache
Set PT = PTcache.CreatePivotTable(TableDestination:=Sheets("test2").Cells(1, 1))
End With
lWKB.SaveAs hFULLPATH
EXCEL_RESULT_T_EXIT:
On Error Resume Next
lWKB.Close
PT.Application.Quit
lEXCEL_OBJ.Application.Quit
Set lWKB = Nothing
Set lEXCEL_OBJ = Nothing
Application.Echo True
DoCmd.Hourglass False
Exit Function
EXCEL_RESULT_T_ERROR:
Resume EXCEL_RESULT_T_EXIT
I am trying to evaluate if specific cell value in an excel table is "" to use in an if statement in my VB.NET application. I modified the code that I use for writing to excel, but it doesn't work to get the cell value. The code I have:
Sub Excel_LoadProjectsSchedule()
xlApp = New Excel.Application
xlWorkBook = xlApp.Workbooks.Open("G:\100 Databases\Projects Schedule.xlsx")
xlApp.Visible = False
xlWorkSheet = xlWorkBook.Worksheets("sheet1")
Dim ProjectFinished as boolean
'Set variables
Result = xlWorkSheet.Cells.Find(ProjectNumber, LookAt:=Excel.XlLookAt.xlWhole)
If xlWorkSheet.Cells(Result.Row, 3).value = "" Then
ProjectFinished = False
Else
ProjectFinished = True
End If
'Save and close
xlApp.DisplayAlerts = False
xlWorkBook.Close(SaveChanges:=True)
xlApp.Quit()
End Sub
Error is on
If xlWorkSheet.Cells(Result.Row, 3).value = "" Then
And it says "System.MissingMemberException: 'Public member 'value' on type 'Range' not found.'
"
I do have
Public xlApp As Excel.Application = Nothing
Public xlWorkBook As Excel.Workbook = Nothing
Public xlWorkSheet As Excel.Worksheet = Nothing
Outside the sub in this module.
What am I doing wrong, could someone, please, help me solve this one?
I did some casting so the compiler can recognize the types.
Sub Excel_LoadProjectsSchedule(ProjectNumber As Integer)
Dim xlApp = New Excel.Application
Dim xlWorkBook = xlApp.Workbooks.Open("G:\100 Databases\Projects Schedule.xlsx")
xlApp.Visible = False
Dim xlWorkSheet = DirectCast(xlWorkBook.Worksheets("sheet1"), Excel.Worksheet)
Dim ProjectFinished As Boolean
'Set variables
Dim Result = xlWorkSheet.Cells.Find(ProjectNumber, LookAt:=Excel.XlLookAt.xlWhole)
Dim row = Result.Row
Dim cell = DirectCast(xlWorkSheet.Cells(row, 3), Excel.Range)
If cell.Value Is Nothing Then
'What do you want to do?
Else
If cell.Value.ToString = "" Then
ProjectFinished = False
Else
ProjectFinished = True
End If
End If
'Save and close
xlApp.DisplayAlerts = False
xlWorkBook.Close(SaveChanges:=True)
xlApp.Quit()
End Sub
I think if you specifically want to check contents in the 3rd Column of the Row with that Projectnumber you're not far away from the Solution.
I only tested it inside of VBA but something along the Lines of:
Sub Excel_LoadProjectsSchedule()
Dim xlWorksheet As Worksheet, Result As Range, ProjectFinished As Boolean
xlApp = New Excel.Application
xlWorkBook = xlApp.Workbooks.Open("G:\100 Databases\Projects Schedule.xlsx")
xlApp.Visible = False
Set xlWorkSheet = xlWorkBook.Worksheets("sheet1")
'Set variables
Set Result = xlWorksheet.Cells.Find(Projectnumber, LookIn:=Excel.XlLookin.xlValues, LookAt:=Excel.XlLookAt.xlWhole)
if not Result is nothing then
If Cells(Result.Row, 3).Value = "" Then
ProjectFinished = False
Else
ProjectFinished = True
End If
End Sub
The Problem being, that "Result" hasn't been asigned to a Range, so your code coudn't access the Row Property.
If looking for a certain cell in certain row .
Dim AppExcel As Object
Dim workBook As Object
AppExcel = CreateObject("Excel.Application")
workBook = AppExcel.Workbooks.Open("C:\SO\SO.xlsx")
AppExcel.Visible = False
Worksheets = workBook.worksheets
If Worksheets("Blad1").Cells(2, 3).text = "" Then
MessageBox.Show("Empty")
Else
MessageBox.Show("Text")
End If
Then the close part
Below is part of a code that i am using to paste charts into ppt. It is basically picking charts from excel to update the existing ppt. I have also included inline text. where i am getting this error. Please help me identify, why this error is existing.
I am getting error at below line :-
m = shp.TextFrame.TextRange.Find(existing_date_string).Characters.Start
Sub ChangeChartData_phast()
Dim pptChart As Chart
Dim pptChartData As ChartData
Dim sld As Slide
Dim shp As Shape
Dim wbk As Workbook
Dim wbk_copy As Workbook
Dim wbk_paste As Worksheet
Dim filepath As String
filepath = ActivePresentation.Path
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
Set wbk_copy = xlApp.Workbooks.Open(filepath & "\development file.xlsm", True, False)
'xlApp.Visible = True
date_string = (wbk_copy.Worksheets("Data").Cells(13, 2))
existing_date_string = (wbk_copy.Worksheets("Data").Cells(14, 2))
wbk_copy.Close True
Set xlApp = Nothing
Set xlApp = CreateObject("Excel.Application")
Set wbk_copy = xlApp.Workbooks.Open(filepath & "\Phast Charts Data.xlsx", True, False)
xlApp.Visible = True
Dim n As Integer
i = i + 1
For Each shp In sld.Shapes
If shp.Name = "Title1" Then
m = shp.TextFrame.TextRange.Find(existing_date_string).Characters.Start
shp.TextFrame.TextRange.Characters(m).InsertBefore (date_string)
shp.TextFrame.TextRange.Find(existing_date_string).Delete
End If
Next
Next n
xlApp.DisplayAlerts = False
wbk_copy.Close False
xlApp.DisplayAlerts = True
Maybe use Replace with a blank string or your text, instead of Delete
shp.TextFrame.TextRange.Replace FindWhat:="###", ReplaceWhat:=""
or try replace using vbNullString.
I wrote this VBA code to generate a report from data in an Access table and dump it into Excel with user friendly formatting.
The code works great the first time. But if I run the code again while the first generated Excel sheet is open, one of my subroutines affects the first workbook instead of the newly generated one.
Why? How can I fix this?
I think the issue is where I pass my worksheet and recordset to the subroutine called GetHeaders that prints the columns, but I'm not sure.
Sub testROWReport()
DoCmd.Hourglass True
'local declarations
Dim strSQL As String
Dim rs1 As Recordset
'excel assests
Dim xlapp As excel.Application
Dim wb1 As Workbook
Dim ws1 As Worksheet
Dim tempWS As Worksheet
'report workbook dimentions
Dim intColumnCounter As Integer
Dim lngRowCounter As Long
'initialize SQL container
strSQL = ""
'BEGIN: construct SQL statement {
--this is a bunch of code that makes the SQL Statement
'END: SQL construction}
'Debug.Print (strSQL) '***DEBUG***
Set rs1 = CurrentDb.OpenRecordset(strSQL)
'BEGIN: excel export {
Set xlapp = CreateObject("Excel.Application")
xlapp.Visible = False
xlapp.ScreenUpdating = False
xlapp.DisplayAlerts = False
'xlapp.Visible = True '***DEBUG***
'xlapp.ScreenUpdating = True '***DEBUG***
'xlapp.DisplayAlerts = True '***DEBUG***
Set wb1 = xlapp.Workbooks.Add
wb1.Activate
Set ws1 = wb1.Sheets(1)
xlapp.Calculation = xlCalculationManual
'xlapp.Calculation = xlCalculationAutomatic '***DEBUG***
'BEGIN: Construct Report
ws1.Cells.Borders.Color = vbWhite
Call GetHeaders(ws1, rs1) 'Pastes and formats headers
ws1.Range("A2").CopyFromRecordset rs1 'Inserts query data
Call FreezePaneFormatting(xlapp, ws1, 1) 'autofit formatting, freezing 1 row,0 columns
ws1.Name = "ROW Extract"
'Special Formating
'Add borders
'Header background to LaSenza Pink
'Fix Comment column width
'Wrap Comment text
'grey out blank columns
'END: Report Construction
'release assets
xlapp.ScreenUpdating = True
xlapp.DisplayAlerts = True
xlapp.Calculation = xlCalculationAutomatic
xlapp.Visible = True
Set wb1 = Nothing
Set ws1 = Nothing
Set xlapp = Nothing
DoCmd.Hourglass False
'END: excel export}
End Sub
Sub GetHeaders(ws As Worksheet, rs As Recordset, Optional startCell As Range)
ws.Activate 'this is to ensure selection can occur w/o error
If startCell Is Nothing Then
Set startCell = ws.Range("A1")
End If
'Paste column headers into columns starting at the startCell
For i = 0 To rs.Fields.Count - 1
startCell.Offset(0, i).Select
Selection.Value = rs.Fields(i).Name
Next
'Format Bold Text
ws.Range(startCell, startCell.Offset(0, rs.Fields.Count)).Font.Bold = True
End Sub
Sub FreezePaneFormatting(xlapp As excel.Application, ws As Worksheet, Optional lngRowFreeze As Long = 0, Optional lngColumnFreeze As Long = 0)
Cells.WrapText = False
Columns.AutoFit
ws.Activate
With xlapp.ActiveWindow
.SplitColumn = lngColumnFreeze
.SplitRow = lngRowFreeze
End With
xlapp.ActiveWindow.FreezePanes = True
End Sub
When Cells and Columns are used alone, they refer to ActiveSheet.Cells and ActiveSheet.Columns.
Try to prefix them with the targeted sheet:
Sub FreezePaneFormatting(xlapp As Excel.Application, ws As Worksheet, Optional lngRowFreeze As Long = 0, Optional lngColumnFreeze As Long = 0)
ws.Cells.WrapText = False
ws.Columns.AutoFit
...
End Sub
Okay, I figured out the issue here. I guess I can't use the ".Select" or "Selection." when I'm working with an invisible, non updating workbook. I found that when I changed some code from automated selecting to simply directly changing the value of cells, it worked out.
OLD:
startCell.Offset(0, i).Select
Selection.Value = rs.Fields(i).Name
NEW:
ws.Cells(startCell.Row, startCell.Column).Offset(0, i).Value = rs.Fields(i).Name
I have worksheets I want to copy to a new, temporary workbook -- without saving it.
Worksheet.Copy copies the worksheet to a new, unnamed'ish (Book1, Book2, Book3, etc) workbook. I want all sheets to be copied to the same workbook.
For all worksheets after the first, I have tried using Worksheet.Copy After:=xlWb.Sheets(1), but I do not know how to reference the newly created workbook when setting the xlWb workbook-object. I keep receiving
run-time error 9, 'Subscript out of range'.
Dim xlApp As Excel.Application
Dim xlWb As Excel.Workbook
Dim xlWbOld As String
Dim xlWs As Excel.Worksheet
Dim xlWbNew As Excel.Workbook
Dim xlWsOld As Excel.Worksheet
Dim xlRng As Excel.Range
Dim xlRngOld As Excel.Range
xlWbOld = ActiveWorkbook.Name
Set xlApp = New Excel.Application
xlApp.Visible = True '*** Quite Important to set Excel.Visible,_
'Otherwise user wouldn't see the application's running _
'even though it would run as background
xlApp.Application.ScreenUpdating = False
Set xlWb = xlApp.Workbooks.Add 'Create a new Workbook
Set xlWs = xlWb.Worksheets.Add
And this is where the worksheets should be copied:
Select Case strRptType
Case "DAILY"
xlWs.Name = "1-Daily Price"
'Check the last column and the last row
lLastRow = oBasic.GetLast(, "DailyRpt", False, "A")
iLastCol = oBasic.GetLast(, "DailyRpt", True, 4)
Set xlRngOld = wksDailyRpt.Range(wksDailyRpt.Cells(4, 1), wksDailyRpt.Cells(lLastRow, iLastCol))
Application.ScreenUpdating = True
xlRngOld.Copy
Set xlRng = xlWs.Cells(1, 1)
xlRng.PasteSpecial Paste:=xlPasteValues
xlWs.Columns.AutoFit
For Each xlWsOld In ActiveWorkbook.Worksheets
If xlWsOld.Name = "ForwardPrices" Or xlWsOld.Name = "ForwardVolatilities" _
Or xlWsOld.Name = "ForwardReturns" Or xlWsOld.Name = "ForwardCorrelations" Then
Sheets(xlWsOld.Name).Copy After:=Workbooks(xlWb).Sheets(1)
End If
Next xlWsOld
End Select
This little macro goes through all the sheets of all the open workbooks, and copies them after the current sheet.
Sub GatherAllSheets()
Dim Wb As Workbook, Sh As Worksheet
For Each Wb In Workbooks
If Not Wb Is ThisWorkbook Then
For Each Sh In Wb.Worksheets
Sh.Copy after:=ActiveSheet
Next Sh
End If
Next Wb
End Sub
Is this what you need?
Or you need to copy the content of the sheets on the same sheet?
I solved it with the following:
For Each xlWsOld In ActiveWorkbook.Worksheets
If xlWsOld.Name = "ForwardPrices" Or xlWsOld.Name = "ForwardVolatilities" _
Or xlWsOld.Name = "ForwardReturns" Or xlWsOld.Name = "ForwardCorrelations" Then
Set xlRngOld = Nothing
Set xlWsForwards = xlWb.Worksheets.Add
lLastRow = oBasic.GetLast(, xlWsOld.Name, False, "A")
iLastCol = oBasic.GetLast(, xlWsOld.Name, True, 1)
Set xlRngOld = xlWsOld.Range(xlWsOld.Cells(1, 1), xlWsOld.Cells(lLastRow, iLastCol))
xlWsForwards.Name = xlWsOld.Name
xlRngOld.Copy
Set xlRngForwards = xlWsForwards.Cells(1, 1)
xlRngForwards.PasteSpecial Paste:=xlPasteValues
xlWsForwards.Columns.AutoFit
xlWsForwards.Cells(1, 1).Select
Set xlWsForwards = Nothing
End If
Next xlWsOld
skip creating the new workbook, and copy all the sheets in one go.
xlWbOld.Sheets(Array("ForwardPrices", "ForwardVolatilities", "ForwardReturns", "ForwardCorrelations")).Copy
Set xlWb = ActiveWorkbook
this way copying creates the new workbook which becomes ActiveWorkbook. then you can assign it to a workbook object, and reference it by that name later on