I have an Excel Report, there are values in Access which only have TRUE/FALSE Answers. How can I change these values each report to (for example) Open/Closed.
For this report I have got a query (excel_open_projects) which gets all the value I need.
Path = CurrentProject.Path & "\"
filename = "Open_Projects_" & Format(Now(), "YYYYMMDDHHNNSS") & ".xls"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel2003, "excel_open_projects", Path & filename
I have already got a code which changes the Values in the first row:
Public Sub openXL()
'Variables to refer to Excel Objects
Dim MySheetPath As String
Dim Xl As Excel.Application
Dim XlBook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
Dim row_count, i As Integer
' Tell it location of actual Excel file
MySheetPath = Path & filename
MsgBox MySheetPath
'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 Row and the Value in the excel sheet starting at specified cell
XlSheet.Range("A1") = "Column A"
'Clean up and close worksheet
XlBook.Save
XlBook.Close
Set Xl = Nothing
Set XlBook = Nothing
Set XlSheet = Nothing
End Sub
Thanks for your help in advance!
I have solved the Problem:
For i = 1 To row_count
If XlSheet.Range("Y" & i) = "True" Then
XlSheet.Range("Y" & i) = "Yes"
ElseIf XlSheet.Range("Y" & i) = "False" Then
XlSheet.Range("Y" & i) = "No"
End If
Next
Related
Below is code used to copy sheets from source and then rename and place into a destination.
I would like to extend the functionality to use another cell reference to rename the Sheet Name in the newly created file. (Note each copied workbook will only have one sheet.) Then after all the workbooks are copied, renamed, and sheets renamed, merge all the workbooks in the destination path into one.
Sub CopyRenameFile()
Dim src As String, dst As String, fl As String, f2 As String
Dim rfl As String
Dim rf2 As String
'Source directory
src = Range("B3")
'Destination directory
dst = Range("D3")
'File name
fl = Range("B6")
f2 = Range("B7")
'Rename file
rfl = Range("D6")
rf2 = Range("D7")
On Error Resume Next
FileCopy src & "\" & fl, dst & "\" & rfl
FileCopy src & "\" & f2, dst & "\" & rf2
If Err.Number <> 0 Then
MsgBox "Copy error: " & src & "\" & rfl
End If
On Error GoTo 0
Dim xL As Excel.Application
Set xL = New Excel.Application
xL.Visible = True
Dim wb As Excel.Workbook
Set wb = xL.Workbooks.Open(F6)
'In case you don't know how here are two ways to reference a sheet:
Dim sh As Excel.Worksheet
Set sh = xL.Sheets(1)
sh.Name = "TestMeOut"
'Saving and closing are important...
wb.Save
Set wb = Nothing
xL.Quit
Set xL = Nothing
End Sub
If it's the active sheet, use
ActiveSheet.Name = "New Name"
If it isn't the active sheet then use:
Sheets("SheetName").Name = "New Name"
or
Sheets(2).Name = "New Name"
for the last one, the index (2 in the example) is the sheet number counting from left to right starting at 1.
To open an Excel workbook by filename:
Dim xL As Excel.Application
Set xL = New Excel.Application
xL.Visible = True
Dim wb as Excel.Workbook
Set wb = xl.Workbooks.Open(put your filename here as a literal or variable)
'In case you don't know how here are two ways to reference a sheet:
Dim sh As Excel.Worksheet
Set sh = xL.Sheets("Sheet1")
' or
Set sh = xL.Sheets(1)
'put your code here
'Saving and closing are important...
wb.Save
Set wb = Nothing
xL.Quit
Set xL = Nothing
NOTE: to use the Excel references, go to Tool => References and look for the Microsoft Office xx.x Object Library (where xx.x is the version).
My macro runs and pick the name of of the report from a list of access table. But Sometimes I get error anytime a name has " " around it. For example report "WIP" (S8789080)_07_20_15.xlsx
I would get the error because of "WIP". How do I add another code to remove " " from the word WIP? Attached is my full code.
Option Compare Database
Public Function CreatePMReports()
'Turn Warnings Off
DoCmd.SetWarnings False
'Create List of Master Project ID's - all of them
DoCmd.OpenQuery ("qmaktbltMasterProjectID")
'This is for only creating certain PM reports
'DoCmd.OpenQuery ("qmaktbltMasterProjectID_oneoff")
'Create Reports
PMReports
MsgBox ("Weekly PM Reports Complete")
'Turn Warnings On
DoCmd.SetWarnings True
End Function
Public Sub PMReports()
' Set Variables
'Turn Warnings Off
DoCmd.SetWarnings False
'Access
Dim db As Database
Dim rst As Recordset
Dim ssql As String
Dim ssql2 As String
Dim sVariable1 As String
Dim rptpath As String
Dim rptName As String
Dim tmpRptData As String
'Excel
Dim xlApp As Excel.Application
Dim xlWkbk As Excel.Workbook
Dim xlWkbk2 As Excel.Workbook
Dim xlwkbk3 As Excel.Workbook
Dim xlSht As Excel.Worksheet
'Get List of Master Prject ID's
Set db = CurrentDb
Dim DataDate As Date
ssq1 = "SELECT * FROM Calendar"
Set rst = db.OpenRecordset("SELECT *FROM calendar")
DataDate = rst.Fields("reporting date")
ssql = "SELECT * FROM tbltMasterProjectID"
Set rst = db.OpenRecordset("SELECT * FROM tbltMasterProjectID")
rst.MoveFirst
'----------------------------------------------------------------------------------------------
'Loop through whatever records are actually in the master project table, could be one - all per qmaktblMasterProjectID or it's oneoff equivalent
Do While rst.EOF <> True
sVariable2 = rst.Fields("Key")
sVariable1 = rst.Fields("Master Project ID")
'Set Report Path/Name
rptpath = ("G:\TRANS\PPM\9. Enterprise Portfolio & Queue\Clarity Extract\DB and Dashboards\Combined Database\RM DBs\PM\" & sVariable2 & "_" & Format(DataDate, "mm-dd-yy") & ".xlsm")
rptName = ("" & sVariable1 & "_" & Format(DataDate, "mm-dd-yy") & ".xlsm")
'Set Temp Rpt Data Path
tmpRptData = ("C:\DATA\BRM\_Templates\Tmp_PMReportData.xlsx")
'----------------------------------------------------------------------------------------------
'Create Workbook for Master Project
'Set the application
Set xlApp = New Excel.Application
'Make the Application Visible
xlApp.Visible = False
'Set the workbook and the filepath 'Change "C:\Book1.xls " to your own filepath and Workbook name
Set xlWkbk = xlApp.Workbooks.Open("C:\DATA\BRM\_Templates\Template - PM.xlsm ")
'Set the worksheet that you want the workbook to open on
xlApp.Sheets("Data").Select
'Create Workbook Name for PM report
xlWkbk.SaveAs (rptpath)
'Create Workbook Name for PM report
xlWkbk.Close (rptpath)
'----------------------------------------------------------------------------------------------
'Export Project Data
' Update Current Master Project ID
db.Execute ("UPDATE tbltCurrentMasterProjectID SET CurrentMasterProjectID = '" & sVariable1 & "'")
' Export Current Master Project PM View
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "A-Weekly - PMView", tmpRptData
'Export PM View All Resource Data
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "A-Weekly - PMView-rsc", tmpRptData
'----------------------------------------------------------------------------------------------
' Copy Data to Correct Tabs
'Open Workbook
xlApp.DisplayAlerts = False
Set xlWkbk2 = xlApp.Workbooks.Open(rptpath)
Set xlwkbk3 = xlApp.Workbooks.Open(tmpRptData)
'Copy PMView
xlwkbk3.Sheets("A_Weekly___PMView").Select
xlwkbk3.ActiveSheet.Cells.Select
xlwkbk3.ActiveSheet.Cells.Copy
xlWkbk2.Activate
xlWkbk2.Sheets("Data").Select
xlWkbk2.ActiveSheet.Cells.Select
xlWkbk2.ActiveSheet.Paste
xlWkbk2.ActiveSheet.Visible = False
' Copy PM View All Resource Data
xlwkbk3.Activate
xlwkbk3.Sheets("A_Weekly___PMView_rsc").Select
xlwkbk3.ActiveSheet.Cells.Select
xlwkbk3.ActiveSheet.Cells.Copy
xlWkbk2.Activate
xlWkbk2.Sheets("ProjData").Select
xlWkbk2.ActiveSheet.Cells.Select
xlWkbk2.ActiveSheet.Paste
xlWkbk2.RefreshAll
xlWkbk2.RefreshAll
xlWkbk2.RefreshAll
xlWkbk2.ActiveSheet.Visible = False
'Delete TmpPMView Data
xlwkbk3.Activate
xlwkbk3.Sheets("A_Weekly___PMView_rsc").Select
xlwkbk3.Sheets("A_Weekly___PMView").Select
xlwkbk3.ActiveSheet.Delete
xlwkbk3.Sheets("A_Weekly___PMView_rsc").Select
xlwkbk3.ActiveSheet.Delete
'Close Workbooks
xlWkbk2.Save
xlWkbk2.Close (rptpath)
xlwkbk3.Save
xlwkbk3.Close (tmpRptData)
xlApp.Quit
'Turn everything off otherwise yo will have problems with your spreadsheet
Set xlApp = Nothing
Set xlWkbk = Nothing
Set xlSht = Nothing
'----------------------------------------------------------------------------------------------
rst.MoveNext
Loop
rst.Close
DoCmd.SetWarnings True
End Sub
Private Sub test()
DoCmd.SetWarnings True
End Sub
Use the replace function.
Dim str as string
str = Replace(str, """", "")
rptName = Replace(rptName, Chr(34), "")
I have a source folder that contains many xls files. I want to create a master file - collect all information into one database from all files in the given source.
The following code creates 2 columns in master file and enters 2 values from the given source file (one file):
Sub getData()
Dim XL As Excel.Application
Dim WBK As Excel.Workbook
Dim scrFile As String
Dim myPath As String
myPath = ThisWorkbook.path & "\db\" 'The source folder
scrFile = myPath & "1.xlsx" 'Select first file
' Sheet name in the master file is "Sh"
ThisWorkbook.Sheets("Sh").Range("A1").Value = "Column 1"
ThisWorkbook.Sheets("Sh").Range("B1").Value = "Column 2"
Set XL = CreateObject("Excel.Application")
Set WBK = XL.Workbooks.Open(scrFile)
ThisWorkbook.Sheets("Sh").Range("A2").Value = WBK.ActiveSheet.Range("A10").Value
ThisWorkbook.Sheets("Sh").Range("B2").Value = WBK.ActiveSheet.Range("C5").Value
WBK.Close False
Set XL = Nothing
Application.ScreenUpdating = True
End Sub
Now I want to loop through all files and save the values from cells "A10" and "C5" from each file in one database, so the loop should select the next row to save new values.
I have an idea how to loop through all files, but don't know how to switch to the next row:
scrFile = Dir(myPath & "*.xlsx")
Do While scrFile <> ""
Set XL = CreateObject("Excel.Application")
Set WBK = XL.Workbooks.Open(scrFile)
' Here should be the code to save the values of A10 and C5 of the given file
'in the loop in next available row of the master file.
WBK.Close False
Set XL = Nothing
scrFile = Dir
Loop
Any help will be highly appreciated! :)
For simplicity, just use a counter:
scrFile = Dir(myPath & "*.xlsx")
n = 1 ' skip the first row with headers
Do While scrFile <> ""
n = n + 1
Set XL = CreateObject("Excel.Application")
Set WBK = XL.Workbooks.Open(scrFile)
' save the values of A10 and C5 of the given file in the next row
ThisWorkbook.Sheets("Sh").Range("A" & n).Value = WBK.ActiveSheet.Range("A10").Value
ThisWorkbook.Sheets("Sh").Range("B" & n).Value = WBK.ActiveSheet.Range("C5").Value
WBK.Close False
Set XL = Nothing
scrFile = Dir
Loop
msgbox n & " files imported."
BTW, you don't need to start a second Excel instance (CreateObject("Excel.Application")) just to open a second workbook. This will slow down your code a lot. Just open, read and close it. Address your master workbook not by ThisWorkbook but assign a varible to it:
Dim masterWB As Excel.Workbook
set masterWB = ThisWorkbook
...
masterWB.Sheets("Sh").Range("A" & n).Value = WBK.ActiveSheet.Range("A10").Value
You need to recalculate last row in the loop wtih End() function.
Like this for range .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
Or to have an integer .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
Give this a try :
Sub getData()
Application.ScreenUpdating = False
Dim XL As Excel.Application, _
WBK As Excel.Workbook, _
MS As Worksheet, _
scrFile As String, _
myPath As String
'Sheet name in the master file is "Sh"
Set MS = ThisWorkbook.Sheets("Sh")
'The source folder
myPath = ThisWorkbook.Path & "\db\"
MS.Range("A1").Value = "Column 1"
MS.Range("B1").Value = "Column 2"
Set XL = CreateObject("Excel.Application")
scrFile = Dir(myPath & "*.xlsx")
Do While scrFile <> ""
Set WBK = XL.Workbooks.Open(scrFile)
' Here should be the code to save the values of A10 and C5 of the given file
'in the loop in next available row of the master file.
With MS
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Value = WBK.ActiveSheet.Range("A10").Value
.Range("B" & .Rows.Count).End(xlUp).Offset(1, 0).Value = WBK.ActiveSheet.Range("C5").Value
End With
WBK.Close False
scrFile = Dir
Loop
XL.Quit
Set XL = Nothing
Set MS = Nothing
Set WBK = Nothing
Application.ScreenUpdating = True
End Sub
I actually have a code here that will loop through each file and deposit the code into your main file. You are also able to choose the directory of the target folder.
Sub GatherData()
Dim sFolder As String
Application.ScreenUpdating = True
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder..."
.Show
If .SelectedItems.Count > 0 Then
sFolder = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
Call Consolidate(sFolder, ThisWorkbook)
End Sub
Private Sub Consolidate(sFolder As String, wbMaster As Workbook)
Dim wbTarget As Workbook
Dim objFso As Object
Dim objFiles As Object
Dim objSubFolder As Object
Dim objSubFolders As Object
Dim objFile As Object
Dim ary(3) As Variant
Dim lRow As Long
'Set Error Handling
On Error GoTo EarlyExit
'Create objects to enumerate files and folders
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFiles = objFso.GetFolder(strFolder).Files
Set objSubFolders = objFso.GetFolder(strFolder).subFolders
'Loop through each file in the folder
For Each objFile In objFiles
If InStr(1, objFile.Path, ".xls") > 0 Then
Set wbTarget = Workbooks.Open(objFile.Path)
With wbTarget.Worksheets(1)
ary(0) = .Range("B8") 'here you can change the cells you need the data from
ary(1) = .Range("B12")
ary(2) = .Range("B14")
End With
With wbMaster.Worksheets(1)
lRow = .Range("E" & .Rows.Count).End(xlUp).Offset(1, 0).Row 'here you can change the row the data is deposited in
.Range("E" & lRow & ":G" & lRow) = ary
End With
wbTarget.Close savechanges:=False
End If
Next objFile
'Request count of files in subfolders
For Each objSubFolder In objSubFolders
Consolidate objSubFolder.Path, wbMaster
Next objSubFolder
EarlyExit:
'Clean up
On Error Resume Next
Set objFile = Nothing
Set objFiles = Nothing
Set objFso = Nothing
On Error GoTo 0
End Sub
My requirement is
1) To open a existing Excel workbook
2) Identify the next empty row and enter time stamp to that row
3) Save and Close the Excel work book
To achieve this I used below code:
Sub UpdateReport()
Dim directory As String, fileName As String
Dim FirstBlankCell As Range
Application.ScreenUpdating = False
directory = "C:\Users\Desktop\Excel_sheets\"
fileName = Dir(directory & "Reports.xls")
Set wbr = Workbooks.Open(directory & fileName, ReadOnly:=False)
Set FirstBlankCell = Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
FirstBlankCell.Activate
myTimeStamp = Format(Now, "yyyy-mm-dd_hhmmss")
FirstBlankCell.Value = myTimeStamp
wbr.Saved = True
'wbr.Close True
End Sub
Problem I am facing is this code updates the sheet only if its open and also it overwrites the values.
I want the time-stamp to be set in next empty cell rather than over writing the old cell without keeping the excel open
Following piece of code should fulfill your requirement:
Sub UpdateReport()
Dim directory As String, fileName As String
Dim FirstBlankCell As Range
directory = "C:\Users\raj.kamal\Documents"
fileName = "stack1.xlsx"
Application.ScreenUpdating = False
Set ExcelAppl = CreateObject("Excel.Application")
Set wb = Application.Workbooks.Open(directory & "/" & fileName, ReadOnly:=False)
wb.Activate
Set ws = wb.Worksheets(1)
Set FirstBlankCell = ws.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
myTimeStamp = Format(Now, "yyyy-mm-dd_hhmmss")
ws.Activate
FirstBlankCell = myTimeStamp
wb.Save
wb.Close
ExcelAppl.Quit
Set wb = Nothing
Set ExcelAppl = Nothing
End Sub
I have a form, within the form I have an object (worksheet) that has excel file in it.
Then I have a button that would calculate the sum of the field in the worksheet, and displays it's sum in the field of the form. How do I code that? The idea is like this
totalr = SUM (A2:A51)
doc.total = totalr
If you're doing this on a form that will be used from a Notes client and the machine running the Notes client has Excel then you can use VBA. Just extract the file to the user's hard drive, open it with Excel, add a cell at the bottom of the column and put a SUM() function there, get that new cell's value, update the field in the UIDOC and then erase the temp file.
The code below presumes you have a form with a RichText field (containing the Excel file) called "excelfile", a field called "Sum" that will contain the sum value from the Excel file, and a button that contains the code. Additionally the document will have to be saved with the attachment for the code to work.
Hope it helps.
Sub Click(Source As Button)
On Error Goto errorhandler
Dim s As New NotesSession
Dim ws As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Set uidoc = ws.CurrentDocument
Dim doc As NotesDocument
Set doc = uidoc.Document
Dim rtitem As NotesRichTextItem
Dim isfileopen As Boolean
Dim filename As String, rows As Double, cols As Double, colToSum As String, c As Integer
Dim xlApp As Variant, xlWorkbook As Variant, xlSheet As Variant, pathname As String
isfileopen = False
'convert column letter to number
colToSum = "A"
c = Asc(colToSum) - 64
'extract file
pathname = s.GetEnvironmentString( "Directory", True ) & "\"
Set rtitem = doc.GetFirstItem("excelfile")
If Not (doc.HasEmbedded) Then
Msgbox "There are no file attachments on this document"
Goto ExitGracefully
End If
Forall o In rtitem.EmbeddedObjects
If ( o.Type = EMBED_ATTACHMENT ) Then
filename = pathname & o.Name
Call o.ExtractFile( filename )
End If
End Forall
'open file
Print "Opening file " & filename & "..."
Set xlApp = CreateObject("Excel.Application")
xlApp.Workbooks.Open filename
isfileopen = True
'get sheet
Print "Gathering data ..."
Set xlWorkBook = xlApp.ActiveWorkbook
Set xlSheet = xlWorkBook.ActiveSheet
xlSheet.Cells.SpecialCells(11).Activate
rows = xlApp.ActiveWindow.ActiveCell.Row
cols = xlApp.ActiveWindow.ActiveCell.Column
'add a row and put the sum() formula there
Print "Computing sum with Excel..."
xlSheet.Cells( rows+1, c ).value = "=SUM(" & colToSum & "1:" & colToSum & Cstr(rows) & ")"
'update UI doc
Call uidoc.FieldSetText( "Sum", Cstr(xlSheet.Cells( rows+1, c ).value) )
exitgracefully:
'close excel
Print "Closing Excel..."
If Not xlWorkbook Is Nothing Then
xlWorkbook.Close False
End If
If Not xlApp Is Nothing Then
xlApp.DisplayAlerts = False
xlApp.Quit
Set xlApp = Nothing
End If
If isfileopen Then
'remove temp file
Print "Removing " & filename
Kill filename
End If
'done
Print "Done"
Exit Sub
errorhandler:
Msgbox Error & " line " & Erl
Exit Sub
End Sub