I need to come up with an updated VBA script that will transfer the result from an Access 2010 request into an existing Excel file, after the current content.
Here is the previous script, that worked with Access 97.
Private Sub CmdTransfert_Click()
On Error GoTo Err_CmdTransfert_Click
Dim Requete As QueryTable
Dim appXL As Excel.Application
Dim Classeur As Excel.Workbook
Dim Cellule As Excel.Range
Dim Plage As Excel.Range
' Bills that needs to be transfered
DoCmd.OpenQuery "Liste_factures_numero"
' Select answers
SendKeys "^a", True
' Copy
SendKeys "^c", True
' Opening Excel
Set appXL = CreateObject("Excel.Application")
appXL.Visible = True
'Only XL 97 supports UserControl Property
On Error Resume Next
appXL.UserControl = True
Set Classeur = appXL.Workbooks.Open("C:\Users\me\Desktop\copiedetravailvlvaccdb\reglements.xlsx")
Set Cellule = Classeur.Worksheets(1).Cells(Classeur.Worksheets(1).Range("a1").CurrentRegion.Rows.Count + 1, 1)
Cellule.Select
' Paste
SendKeys "^v", True
' Cellule.PasteSpecial xlPasteValues
' Deleting titles
Cellule.EntireRow.Delete
'Fixing date format
Set Plage = Selection
For Each Cellule In Plage
If Cellule.Column = 2 Then
If Cellule.Value <> "" Then
Cellule.Value = CDate(Cellule.Value)
End If
End If
Next
' Mise au format normal
Range("A3:D3").Copy
Plage.PasteSpecial Paste:=xlFormats
Excel.Application.CutCopyMode = False
' Closing request
DoCmd.Close acQuery, "Liste_factures_numero", acSaveNo
Exit_CmdTransfert_Click:
Exit Sub
Err_CmdTransfert_Click:
MsgBox Err.Description
Resume Exit_CmdTransfert_Click
End Sub
I have tried adding Sleep commands around the Sendkeys instruction, it did not worked. The result was not selected, thus not copied nor pasted.
As last resort I tried creating a new script using DoCmd.TransferSpreadsheet, but I can't figure how to add the new content after the existing one.
DoCmd.TransferSpreadsheet acExport, , "Liste_factures_numero", "C:\Users\me\Desktop\copiedetravailvlvaccdb\reglements.xlsx", True
However as expected it overwrite the content.
This is my first time with VBA.
You can change this:
DoCmd.OpenQuery "Liste_factures_numero"
' Select answers
SendKeys "^a", True
' Copy
SendKeys "^c", True
To this:
DoCmd.OpenQuery "Liste_factures_numero"
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
And this:
' Paste
SendKeys "^v", True
To this:
Cellule.PasteSpecial Paste:=xlPasteValues
Also, I must add that it's another way to achieve this copy-pasting from Access to Excel via macros:
Make connection to Access file;
Get data from query into recordset;
Paste data on excel sheet;
Use formatting on pasted cells (font, size etc).
Something like this, changing worksheets/column A as necessary:
Dim r As Range
Set r = ThisWorkbook.Worksheets(1).Range("A1").End(xlDown).Offset(1, 0)
DoCmd.TransferSpreadsheet acExport, , "Liste_factures_numero" _
, ThisWorkbook.FullName & Chr(35) & "Sheet1", True, r.Address
Related
I am working on exporting filtered table data from Access to an Excel sheet, yet I can only get the table data to export into new Excel files and not into template Excel files (with pre-made graphs to be populated).
I mainly have been using macros on Access to create a switchboard where the user presses a switchboard-button and the filtered data exports from a table in Access to a new Excel file in a Reports folder. I do not know that macros are able to export with template Excel files, so I have turned to learning VBA. I am new to VBA so I apologize for my trivial understanding. I have created some VBA code based off of a tutorial from Access Jujitsu on Youtube.
Private Sub Command0_Click()
On Error GoTo SubError
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim SQL As String
Dim rs1 As DAO.Recordset
Dim i As Integer
Dim qtr As String
'Show user work is being performed
DoCmd.Hourglass (True)
'*********************************************
' RETRIEVE DATA
'*********************************************
'SQL statement to retrieve data from database
SQL = "SELECT Obj, Owner, Recom, Goal, Quality of Measure" & _
"FROM Inventory " & _
"WHERE Owner = ASM" &
"ORDER BY Recom "
'Execute query and populate recordset
Set rs1 = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)
'If no data, don't bother opening Excel, just quit
If rs1.RecordCount = 0 Then
MsgBox "No data selected for export", vbInformation + vbOKOnly, "No data exported"
GoTo SubExit
End If
'*********************************************
' BUILD SPREADSHEET
'*********************************************
'Create an instance of Excel and start building a spreadsheet
'Early Binding
Set xlApp = Excel.Application
xlApp.Visible = True
Set xlBook = xlApp.Workbooks.Open("\Users\Desktop to TemplateACC.xlsx")
Set xlSheet = xlBook.Worksheets(1)
With xlSheet
'Set second page title - pull quarter and year off of first row
'Won't work if you are pulling multiple time periods!
Select Case Nz(rs1!SalesQuarter, "")
Case 1
qtr = "1st"
Case 2
qtr = "2nd"
Case 3
qtr = "3rd"
Case 4
qtr = "4th"
Case Else
qtr = "???"
End Select
.Range("B3").Value = qtr & " Quarter " & Nz(rs1!SalesYear, "????")
'provide initial value to row counter
i = 1
'Loop through recordset and copy data from recordset to sheet
Do While Not rs1.EOF
.Range("I" & i).Value = Nz(rs1!Owner, "")
.Range("J" & i).Value = Nz(rs1!Goal, 0)
.Range("K" & i).Value = Nz(rs1!Recom, 0)
i = i + 1
rs1.MoveNext
Loop
End With
SubExit:
On Error Resume Next
DoCmd.Hourglass False
xlApp.Visible = True
rs1.Close
Set rs1 = Nothing
Exit Sub
SubError:
MsgBox "Error Number: " & Err.Number & "= " & Err.Description, vbCritical + vbOKOnly, _
"An error occurred"
GoTo SubExit
End Sub
Private Sub Form_Load()
End Sub
My code will not run as it says the "User-defined type is not defined" upon error. I have built this code from a button on a new form, opening the VBA coding template by building the event from the button. I am not sure why the code will not run. It is supposed to export to a pre-existing file called "TemplateACC" but instead this error appears. Thank you for sticking with me on this!
Have you added the Excel object library?
In the VBA editor go to Tools -> References, find Microsoft Excel 1X.0 Object Library and check it.
X depends on the version of Excel installed, but there should only be one, probably 14 to 16.
Binding may be your issue. You can implement early binding by adding the MS Excel Object Library to your References (Tools --> References), or you can implement late binding like below:
Private Sub Command0_Click()
Dim xlApp As object
Dim xlBook As object
Dim xlSheet As object
''If excel is already Running, grab that instance of the program, if not, create new
set xlApp = GetExcel
set xlBook = xlApp.Workbooks.Open("\Users\Desktop to TemplateACC.xlsx")
Set xlSheet = xlBook.Worksheets(1)
''... do other stuff
End sub
Function GetExcel() As Object 'Excel.Application
'Updated: 2009-10-13
'Used to grab the Excel application for automation
If DetectExcel Then
Set GetExcel = GetObject(, "Excel.Application")
Else
Set GetExcel = CreateObject("Excel.Application")
End If
End Function
Function DetectExcel() As Boolean
' Procedure dectects a running Excel and registers it.
Const WM_USER = 1024
Dim hwnd As Long
''If Excel is running this API call returns its handle.
hwnd = FindWindow("XLMAIN", 0)
If hwnd = 0 Then ' 0 means Excel not running.
DetectExcel = False
Exit Function
''Excel is running so use the SendMessage API
''function to enter it in the Running Object Table.
DetectExcel = True
SendMessage hwnd, WM_USER + 18, 0, 0
End If
End Function
I'm using the below code to copy column B in combinedWorkbook to column B in ThisWorkbook but when running the macro it seems to paste column B into column C of ThisWorkbook as well as pasting into column B. I've stepped through the code and it works fine. This seems very strange and would be grataeful with any help on why it's also pasting into column C in ThisWorkbook.
Sub ImportWriteOffs()
Dim filter As String
Dim caption As String
Dim combinedFilename As String
Dim combinedWorkbook As Workbook
' Open BRAM Report Source Data
MsgBox ("Select 'SRMF0035 BRAM Pre Repurchase'")
filter = "Text files (*.*),*.*"
caption = "Select 'SRMF0035 BRAM Pre Repurchase'"
combinedFilename = Application.GetOpenFilename(filter, , caption)
If combinedFilename <> "False" Then
Set combinedWorkbook = Application.Workbooks.Open(combinedFilename)
Else
MsgBox "No file was uploaded", vbExclamation
GoTo LastLine
End If
If combinedWorkbook.Worksheets(1).Range("D7").Value = "Periodic Insurance" Then
' Copy and Paste into working file
Sheets("Tabular Version").Select
Range("B10:B100000").Select
Selection.Copy
ThisWorkbook.Activate
Sheets("Input - Write offs").Select
Range("B10:B100000").Select
ActiveSheet.Paste
Application.CutCopyMode = False
combinedWorkbook.Close False
' Delete last row
ThisWorkbook.Activate
Sheets("Input - Write offs").Select
Range("B10").Select
Selection.End(xlDown).Select
Selection.EntireRow.Delete
Else
MsgBox "Incorrect File Selected"
combinedWorkbook.Close False
Exit Sub
End If
LastLine:
End Sub
You can try this. Notice that you do not need to .Select a cell to copy it. It defeats the purpose of VBA! Just get right to the point: State the range and copy it. No need to select.
Also, no need for GoTo as mentioned by the infamous #ashleedawg, just Exit Sub when needed.
Sub ImportWriteOffs()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Input - Write offs")
Dim filter As String, caption As String, combinedFilename As String
Dim combinedWorkbook As Workbook, ws2 as Worksheet
MsgBox ("Select 'SRMF0035 BRAM Pre Repurchase'")
filter = "Text files (*.*),*.*"
caption = "Select 'SRMF0035 BRAM Pre Repurchase'"
combinedFilename = Application.GetOpenFilename(filter, , caption)
If combinedFilename <> "False" Then
Set combinedWorkbook = Application.Workbooks.Open(combinedFilename)
Set ws2 = combinedWorkbook.Sheets("Tabular Version")
Else
MsgBox "No file was uploaded", vbExclamation
Exit Sub
End If
If combinedWorkbook.Worksheets(1).Range("D7") = "Periodic Insurance" Then
ws2.Range("B10:B" & ws2.Range("B" & ws.Rows.Count).End(xlUp).Row - 1).Copy
ws.Range("B10").PasteSpecial xlPasteValues
ws.Range("B10").PasteSpecial xlPasteFormats
combinedWorkbook.Close False
Else
MsgBox "Incorrect File Selected"
combinedWorkbook.Close False
End If
End Sub
This is happening because the select is actually using a relative reference. But it would be clearer what you want to do if you used Cells instead:
For r = 10 to 10000
ActiveWorkbook.Worksheets("Input - Write-offs").Cells(r, 2) = combinedWorkbook.Worksheets("Tabular Version").Cells(r, 2)
Next
You can implement something similar for deleting the last row, if you are so inclined.
I have a macro which create a copy of a workbook in VBA. I want this copy "Read Only", but the property ReadOnly := True doesn't work.
Here's the code:
The first macro:
Sub SaveXL()
Dim Nom2 As String
Dim Jour2 As String
Dim FPath2 As String
Jour2 = Format(Now(), "yyyymmdd - h\hmm")
Nom2 = Jour2 & " Pricelist"
FPath2 = Sheets("PARAM").Range("B33").Value
On Error GoTo fin4
fichier = Application.GetSaveAsFilename(FPath2 & Nom2, "Fichiers Excel (*.xls), *.xls")
If fichier <> "Faux" Then
ActiveWorkbook.SaveCopyAs fichier
VBA.SetAttr fichier, vbReadOnly
Test GetAName(fichier)
Else
MsgBox "Le fichier n'a pas été enregistré"
End If
Exit Sub
fin4: MsgBox "La création de l'excel a échoué"
End Sub
The second:
Sub Test(targetWorkbookName As String)
Dim F As Integer, C As Integer, derniereligne
Dim targetWorkbook As Workbook
On Error Resume Next
Set targetWorkbook = Workbooks(targetWorkbookName)
On Error GoTo 0
If (targetWorkbook Is Nothing) Then _
Set targetWorkbook = Workbooks.Open(Filename := targetWorkbookName, ReadOnly := True)
For F = 1 To Sheets.Count
ActiveSheet.Select
For C = 15 To 2 Step -1
ActiveSheet.Columns(C).Select
Selection.End(xlDown).Select
derniereligne = ActiveCell.Row
If ActiveSheet.Columns(C).Hidden = True Then
ActiveSheet.Columns(C).Delete
End If
Next C
Next F
Application.DisplayAlerts = False
Sheets("PARAM").Delete
ActiveWorkbook.ActiveSheet.Shapes.Range(Array("Button 2")).Select
Selection.Delete
ActiveWorkbook.ActiveSheet.Shapes.Range(Array("Button 9")).Select
Selection.Delete
targetWorkbook.SaveAs Filename:=targetWorkbookName, FileFormat:=xlOpenXMLWorkbook
End Sub
If you want to make the workbook un-saveable you can do the following instead:
In the ThisWorkbook module use:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Cancel = True
End Sub
Then got to the immediate window (press Ctrl + G) and type:
Application.EnableEvents = False - hit Enter
ThisWorkbook.Save - hit Enter
Application.EnableEvents = True - hit Enter
Now when a user tries to save the workbook it will simply cancel the save, meaning the data can't be permanently overwritten.
ActiveWorkbook.ChangeFileAccess Mode:=xlReadOnly
Read-only is a file system permission not one controlled by Excel
Read-only recommended is the Excel controlled version of it in with the user is prompted to open it as read-only (but they can choose no).
To save a copy of a workbook as read-only recommended you need to: -
Save a copy using SaveCopyAs
Open the copy
Save the copy using SaveAs with the property ReadOnlyRecommended set to true
Delete the previous copy made in the first instruction
Below is a small example of this:-
Public Sub Make_Copy_ReadOnlyRec()
Dim WkBk As Excel.Workbook
'Using SaveCopyAs
ThisWorkbook.SaveCopyAs Environ("UserProfile") & "\Desktop\Temp.xlsm"
'Open the copy
Set WkBk = Application.Workbooks.Open(Environ("UserProfile") & "\Desktop\Temp.xlsm")
'Use save as to make it read only recommended
WkBk.SaveAs Environ("UserProfile") & "\Desktop\Sample.xlsm", XlFileFormat.xlOpenXMLWorkbookMacroEnabled, , , True
'Close the now read only recommended copy
WkBk.Close
Set WkBk = Nothing
'Delete the original copy
Kill Environ("UserProfile") & "\Desktop\Temp.xlsm"
End Sub
I just need the IF line that says that if he tries to open the file that runs the code(Trying to open himself) then skip it.
Here is the code I have so far.
Sub Auto_Open()
Dim SrcBook As Workbook
Dim fso As Object, f As Object, ff As Object, f1 As Object
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.Getfolder("C:\test\new")
Set ff = f.Files
For Each f1 In ff
Set SrcBook = Workbooks.Open(f1)
Range("A2:IV" & Range("A20").End(xlUp).Row).Copy
ThisWorkbook.Worksheets(1).Activate
Range("A20").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
SrcBook.Close
Next
End Sub
If Not ThisWorkbook.FullName = f1.Path Then
Set SrcBook = Workbooks.Open(f1)
Range("A2:IV" & Range("A20").End(xlUp).Row).Copy
ThisWorkbook.Worksheets(1).Activate
Range("A20").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
SrcBook.Close
End If
Taking your code as is, you could add the following If-statement to the For Each-loop:
For Each f1 In ff
If StrComp(f1.Name, ActiveWorkbook.Name, vbTextCompare) <> 0 And _
InStr(1, f1.Name, "~") = 0 Then
Set SrcBook = Workbooks.Open(f1)
Range("A2:IV" & Range("A20").End(xlUp).Row).Copy
ThisWorkbook.Worksheets(1).Activate
Range("A20").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
SrcBook.Close
End If
Next
The first condition prevents opening the current file itself, the second condition also skips the temporary file that Excel creates on opening a file.
Reworked Code
Just as an aside, I would refactor and expand the code as follows:
Sub Auto_Open()
On Error GoTo Err_
Dim fso As Object
Dim Folder As Object
Dim Files As Object
Dim File As Object
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder = fso.Getfolder("C:\Temp\Excel")
Set Files = Folder.Files
For Each File In Files
If StrComp(File.Name, ActiveWorkbook.Name, vbTextCompare) <> 0 And _
InStr(1, File.Name, "~") = 0 Then
With Workbooks.Open(File.Path)
Range("A2:IV" & Range("A20").End(xlUp).Row).Copy
ThisWorkbook.Worksheets(1).Activate
Range("A20").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
.Close
End With
End If
Next
Exit_:
Application.ScreenUpdating = True
Set Files = Nothing
Set Folder = Nothing
Set fso = Nothing
Exit Sub
Err_:
Resume Exit_
End Sub
A few remarks:
Error handling to ensure that even in the case of an error ScreenUpdating is switched back on again. Otherwise you could leave your application not refreshing to the user in case of an error.
Separate line for each variable - easier to grasp
More explicit variable names. First and foremost, code should be easy to read, not easy to type.
With-block for the local variable to make it's scope explicit. Saves the local variable SrcBook as well.
Here it might be argued that the name of that variable helped understanding the problem and should better be kept.
Explicit setting the object variables to Nothing. Might be paranoid, but as a SOP it can help to avoid all kind of weird issues in some cases.
Since it might be challenging to get the intent of the code in the With-block is, I would even go further and extract that block into a new method with a intent-revealing name to make things clearer. The name could be along the lines of CopyProductListFromFile.
I have looked everywhere and I didn't find any solution for my problem.
What I need is to change a part of my VBA using a VBscript (or even a CMD).
I have something like this:
Sub Test
If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
NameColumn = Application.WorksheetFunction.Match("Names", Range(Cells(line, column), Cells(line, column + 30)), 0)
Cells(line, colum).Select
Selection.AutoFilter Field:=NameColumn, Criteria1:="=*ABC*", _
Operator:=xlAnd
Selection.End(xlDown).Select
If ActiveCell.Row < 1000 Then
Call Copy("ABC")
End If
SendEmail("ABC is done", emailaddress)
End Sub
What I wanted is a script to change ABC to CDE, FGH and IJK, for instance.
I have a script in VBS which change part of my code if I want:
Const ToRead= 1
Const ToWrite= 2
File= Wscript.Arguments(0)
OldText= Wscript.Arguments(1)
NewText = Wscript.Arguments(2)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(File, ToRead)
strText = objFile.ReadAll
objFile.Close
NewText = Replace(strText, OldText, NewText)
Set objFile = objFSO.OpenTextFile(File, ToWrite)
objFile.Write NewText
objFile.Close
And I also have a code to run a VBA using a VBS:
Sub ExcelMacroExample()
Dim xlApp
Dim xlBook
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open("C:\Documents\Example.xlsm")
xlApp.Run "RunMacro"
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
End Sub
However, I really cant see a connection between those scripts and I didnt find anything on the internet about this problem.
Does anyone know how can I change a part of the VBA code using the VBS?
Using VBS would be the best way to do that, because of other parts of the process I am running. But I would accept different answers.
What about using parametr for your Test sub and pass it using xlApp.Run:
xlApp.Run "Example.xlsm!Test", "ABC"
Test sub with parametr:
Sub Test(str As String)
If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
NameColumn = Application.WorksheetFunction.Match("Names", Range(Cells(Line, Column), Cells(Line, Column + 30)), 0)
Cells(Line, colum).Select
Selection.AutoFilter Field:=NameColumn, Criteria1:="=*" & str & "*", _
Operator:=xlAnd
Selection.End(xlDown).Select
If ActiveCell.Row < 1000 Then
Call Copy(str)
End If
Call SendEmail(str & " is done", emailaddress)
End Sub