I'm having a problem with access-VS it's ways Variable not defined can anyone help me?
This is the code that i'm working on: (am a newbie)
Option Compare Database
Option Explicit
Private Sub btnLogin_Click()
Dim rs As Recordset
Set rs = CurrentDb.OpenRecordset("tbl1Employees", dbOpenSnapshot, dbReadOnly)
rs.FindFirst "UserName='" & Me.txtUserNAme & "'"
If rs.NoMatch = True Then
Me.lblWrongUser.Visible = True
Me.txtUserNAme.SetFocus
Exit Sub
End If
Me.lblWrongUser.Visible = False
If rs!Password <> Nz(Me.txtPassword, "") Then
Me.lblWrongPass.Visible = True
Me.txtPassword.SetFocus
Exit Sub
End If
Me.lblWrongPass.Visible = False
DoCmd.OpenForm "frmMenu"
DoCmd.Close acForm, Me.Name
End Sub
Related
I am trying to rewrite my windows VBA code so i can use it on a Mac computer.
But somehow it is not possible to load the information into an active worksheet on mac.
Where MyFiles is the csv file opened by the code of http://www.rondebruin.nl/mac/mac015.html
.
I broke down the code a bit because i thought it didn't recognize the workbook. But i think the problem lies in the work book.
Set ws = ActiveWorkbook.Sheets("1. Pledges (ruw)")
MyFiles = MacScript(MyScript)
On Error GoTo 0
If MyFiles <> "" Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With ws.QueryTables.Add(Connection:="TEXT;" & MyScript, Destination:=ws.Range("A1"))
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.Refresh
End With
If ws.Range("A2").Value = vbNullString Then
ws.rows("2").EntireRow.Delete
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub
Some how it always crashes on the .refresh even if i use the code of robin the bruijn i can't use the querytables which work perfectly on windows.
Original windows code:
Dim ws As Worksheet, strFile As String
Set ws = ActiveWorkbook.Sheets("1. Pledges (ruw)") 'set to current worksheet name
strFile = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please selec text file...")
With ws.QueryTables.Add(Connection:="TEXT;" & strFile, Destination:=ws.Range("A1"))
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.SaveData = True
End With
If ws.Range("A2").Value = vbNullString Then
ws.rows("2").EntireRow.Delete
End If
I am trying to read multiple CSVs into single spreadsheet. I got below code from google.
There are 10 CSVs present in "C:\Users\achayapa\Desktop\test". I need to have each of these CSVs in a single excel. could someone please help?
I am new to vb script.
Sub MacroLoop()
Dim strFile As String
Dim ws As Worksheet
strFile = Dir("C:\Users\achayapa\Desktop\test\*.csv")
Do While strFile <> vbNullString
ws = Sheets.Add
With ws.QueryTables.Add(Connection:= _
"TEXT;" & "C:\Users\achayapa\Desktop\test\" & strFile, Destination:=Range("$A$1"))
.Name = strFile
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh(BackgroundQuery:=False)
End With
strFile = Dir
Loop
End Sub
I just thought of sharing the answer to above question.
Create a VBA script as below:
Sub Macro1()
Dim strPath As String
Dim strFile As String
strPath = "C:\test\"
strFile = Dir(strPath & "*.csv")
Do While strFile <> ""
With ActiveWorkbook.Worksheets.Add
With .QueryTables.Add(Connection:="TEXT;" & strPath & strFile, _
Destination:=.Range("A1"))
.Parent.Name = Replace(strFile, ".csv", "")
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End With
strFile = Dir
Loop
End Sub
In above code include for path - '\' For example - C:\test\
After this follow include above VBA in Excel, follow steps as in below link:
http://www.ablebits.com/office-addins-blog/2013/12/06/add-run-vba-macro-excel/
Short answer: Yes it is possible.
Step 0 of long answer:
There are 2 syntactical errors in you SWub MacroLoop():
ws = Sheets.Add must be Set ws = Sheets.Add because you want to assign an object to ws.
.Refresh(BackgroundQuery:=False) must be .Refresh BackgroundQuery:=False because you must not use param list () when calling (a function/method as) a Sub (see here).
You may get problems with .TextFilePlatform and .TextFileTrailingMinusNumbers - at least I did when testing on my rather dated Excel. If so, disable those lines (' comment) and try again.
For the next step I would need a detailed account of your testing experience. What result do you expect and how did the actual outcome differ from that?
I am new to VBA and my problem might be stupid, but I cant fix it, so please help me if you can!
Here is the thing: I got userform that fills spreadsheet perfectly, but if information is not entered it does crazy things. As you may see below i found some piece of code to check if the data is entered, so if its not window pops up and you have to enter something, but when you do form fills 2 rows of data instead of one. For example, if pick row 'x' and want to put values 'a','b','c','d', but forgot to put value 'c' then it shows an error and when i type missing value 'c' and press OK it creates row 'x' with values 'a','b',' ','d' and row 'x+1' with values 'a','b','c','d'.
Here is my code:
Private Sub cmdok_Click()
'next empty cell in column A
Set c = Range("a65536").End(xlUp).Offset(1, 0)
Application.ScreenUpdating = False 'speed up, hide task
'write userform entries to database
c.Value = Me.txtFname.Value
c.Offset(0, 3).Value = Me.txtngoals.Value
c.Offset(0, 28).Value = Me.cmbDiag.Value
If Me.optAcute.Value = "True" And Me.optchronic.Value = "False" Then
c.Offset(0, 29).Value = 1
c.Offset(0, 30).Value = ""
Else
c.Offset(0, 29).Value = ""
c.Offset(0, 30).Value = 1
End If
'input validation
If txtFname.Value = "" Then
MsgBox ("Sorry, you need to provide a Name")
txtFname.SetFocus
Exit Sub
End If
If txtngoals.Value = "" Then
MsgBox ("Sorry, you need to provide goals")
txtngoals.SetFocus
Exit Sub
End If
If cmbDiag.Value = "" Then
MsgBox ("Sorry, you need to provide Diagnosis")
cmbDiag.SetFocus
Exit Sub
End If
If optAcute.Value = optchronic.Value Then
MsgBox ("Sorry, you need to select Time since injury")
Exit Sub
End If
'clear the form
With Me
.txtFname.Value = vbNullString
.cmbDiag.Value = vbNullString
.optAcute.Value = vbNullString
.optchronic.Value = vbNullString
.txtngoals.Value = vbNullString
End With
Application.ScreenUpdating = True
End Sub
thank you in advance
Try moving the code "write userform entries to database" to after the validation checks.
Private Sub cmdok_Click()
'next empty cell in column A
Set c = Range("a65536").End(xlUp).Offset(1, 0)
Application.ScreenUpdating = False 'speed up, hide task
'input validation
If txtFname.Value = "" Then
MsgBox ("Sorry, you need to provide a Name")
txtFname.SetFocus
Exit Sub
End If
If txtngoals.Value = "" Then
MsgBox ("Sorry, you need to provide goals")
txtngoals.SetFocus
Exit Sub
End If
If cmbDiag.Value = "" Then
MsgBox ("Sorry, you need to provide Diagnosis")
cmbDiag.SetFocus
Exit Sub
End If
If optAcute.Value = optchronic.Value Then
MsgBox ("Sorry, you need to select Time since injury")
Exit Sub
End If
'write userform entries to database
c.Value = Me.txtFname.Value
c.Offset(0, 3).Value = Me.txtngoals.Value
c.Offset(0, 28).Value = Me.cmbDiag.Value
If Me.optAcute.Value = "True" And Me.optchronic.Value = "False" Then
c.Offset(0, 29).Value = 1
c.Offset(0, 30).Value = ""
Else
c.Offset(0, 29).Value = ""
c.Offset(0, 30).Value = 1
End If
'clear the form
With Me
.txtFname.Value = vbNullString
.cmbDiag.Value = vbNullString
.optAcute.Value = vbNullString
.optchronic.Value = vbNullString
.txtngoals.Value = vbNullString
End With
Application.ScreenUpdating = True
I have two .vbs file say a.vbs and b.vbs.Now both are written for the same Excel,but would work on 2 different sheets.So can we run those in parallel?
EDIT
a.vbs will update sheet2 and b.vbs will update sheet3.But for both source sheet is sheet1.
Please advice how to set such environment
CODE A
Option Explicit
Dim objExcel1
Dim strPathExcel1
Dim objSheet1,objSheet2
Dim IntRow1,IntRow2
Dim ColStart
Set objExcel1 = CreateObject("Excel.Application")'Object for Condition Dump
strPathExcel1 = "D:\AravoVB\Copy of Original Scripts\CopyofGEWingtoWing_latest_dump_21112012.xls"
objExcel1.Workbooks.open strPathExcel1
Set objSheet1 = objExcel1.ActiveWorkbook.Worksheets(1)
Set objSheet2 = objExcel1.ActiveWorkbook.Worksheets("Bad Data")
objExcel1.ScreenUpdating = False
objExcel1.Calculation = -4135 'xlCalculationManual
IntRow2=2
IntRow1=4
Do Until IntRow1 > objSheet1.UsedRange.Rows.Count
ColStart = objExcel1.Application.WorksheetFunction.Match("Parent Business Process ID", objSheet1.Rows(3), 0) + 1
Do Until ColStart > objSheet1.UsedRange.Columns.Count And objSheet1.Cells(IntRow1,ColStart) = ""
If objSheet1.Cells(IntRow1,ColStart + 1) > objSheet1.Cells(IntRow1,ColStart + 5) And objSheet1.Cells(IntRow1,ColStart + 5) <> "" Then
objSheet1.Range(objSheet1.Cells(IntRow1,1),objSheet1.Cells(IntRow1,objSheet1.UsedRange.Columns.Count)).Copy
objSheet2.Range(objSheet2.Cells(IntRow2,1),objSheet2.Cells(IntRow2,objSheet1.UsedRange.Columns.Count)).PasteSpecial
IntRow2=IntRow2+1
Exit Do
End If
ColStart=ColStart+4
Loop
IntRow1=IntRow1+1
Loop
objExcel1.ScreenUpdating = True
objExcel1.Calculation = -4105 'xlCalculationAutomatic
CODE B
Option Explicit
Dim objExcel1
Dim strPathExcel1
Dim objSheet1,objSheet2
Dim IntRow1,IntRow2
Dim Flag
Dim IntColTemp,IntRowTemp
Dim Strcmp1,Strcmp2
Flag=0
IntColTemp=1
IntRowTemp=3
Set objExcel1 = CreateObject("Excel.Application")'Object for Condition Dump
If Err.Number <> 0 Then
On Error GoTo 0
Wscript.Echo "Excel application not found."
Wscript.Quit
End If
strPathExcel1 = "D:\VA\CopyofGEWingtoWing_latest_dump_21112012.xls"
objExcel1.Workbooks.open strPathExcel1
Set objSheet1 = objExcel1.ActiveWorkbook.Worksheets(1)
Set objSheet2 = objExcel1.ActiveWorkbook.Worksheets(2)
IntRow1=4
IntRow2=1
Do While objSheet1.Cells(IntRow1, 1).Value <> ""
objSheet2.Cells(IntRow2, 1).Value = objSheet1.Cells(IntRow1, 1).Value
IntColTemp=1
Flag=0
'This will travarse to the Parent Business Process ID column horizantally in the excel.
Do While Flag=0
If objSheet1.Cells(IntRowTemp,IntColTemp).Value="Parent Business Process ID" Then
Flag=1
End If
IntColTemp=IntColTemp+1
Loop
IntColTemp=IntColTemp-1
'MsgBox(IntColTemp)
Strcmp1=trim(objSheet1.Cells(IntRow1, 1).Value)
Strcmp2=trim(objSheet1.Cells(IntRow1,IntColTemp).Value)
If Strcmp1=Strcmp2 Then
objSheet2.Cells(IntRow2, 2).Value="Parent"
Else
objSheet2.Cells(IntRow2, 2).Value="child"
End If
IntRow1=IntRow1+1
IntRow2=IntRow2+1
Loop
Working on two different sheets should be possible by putting something like this in both of your scripts:
strPathExcel1 = "D:\CopyofGEWingtoWing_latest_dump_21112012.xls"
On Error Resume Next
Set objExcel1 = GetObject(, "Excel.Application") ' attach to running instance
If Err.Number = 429 Then ' if that fails
Err.Clear
Set objExcel1 = CreateObject("Excel.Application") ' create new instance
If Err Then ' if that still fails
WScript.Echo Err.Description & " (0x" & Hex(Err.Number) & ")"
WScript.Quit 1 ' report error and terminate
End If
objExcel1.Workbooks.Open strPathExcel1
End If
On Error Goto 0
However, I doubt that this approach would gain you enough performance to justify the additional complexity.
In CODE A replace the lines
Set objExcel1 = CreateObject("Excel.Application")'Object for Condition Dump
strPathExcel1 = "D:\AravoVB\Copy of Original Scripts\CopyofGEWingtoWing_latest_dump_21112012.xls"
objExcel1.Workbooks.open strPathExcel1
with the above code block.
In CODE B replace the lines
Set objExcel1 = CreateObject("Excel.Application")'Object for Condition Dump
If Err.Number <> 0 Then
On Error GoTo 0
Wscript.Echo "Excel application not found."
Wscript.Quit
End If
strPathExcel1 = "D:\VA\CopyofGEWingtoWing_latest_dump_21112012.xls"
objExcel1.Workbooks.open strPathExcel1
with the above code block.
We want to upgrade our VB6 code to use Outlook 2010, but we're getting the following error:
Active x cannot create object
This is our current code:
Public Sub SendEmail()
Set emailOutlookApp = CreateObject("Outlook.Application.12")
Set emailNameSpace = emailOutlookApp.GetNamespace("MAPI")
Set emailFolder = emailNameSpace.GetDefaultFolder(olFolderInbox)
Set emailItem = emailOutlookApp.CreateItem(olMailItem)
Set EmailRecipient = emailItem.Recipients
EmailRecipient.Add (EmailAddress)
EmailRecipient.Add (EmailAddress2)
emailItem.Importance = olImportanceHigh
emailItem.Subject = "My Subject"
emailItem.Body = "The Body"
'-----Send the Email-----'
emailItem.Save
emailItem.Send
'-----Clear out the memory space held by variables-----'
Set emailNameSpace = Nothing
Set emailFolder = Nothing
Set emailItem = Nothing
Set emailOutlookApp = Nothing
Exit Sub
I'm not sure if "Outlook.Application.12" is correct. But I can't find a definitive answer for this.
For Outlook 2010, this is definitly corect Outlook.Application.14.
But, I don't know what about office 2007.
I think it's Outlook.Application.12 and for lower versions it is simply "Outlook.Application".
Here's the code I switched to for 2010:
Private Sub EmailBlahbutton_Click()
Dim mOutlookApp As Object
Dim OutMail As Object
Dim Intro As String
On Error GoTo ErrorHandler
Set mOutlookApp = GetObject("", "Outlook.application")
Set OutMail = mOutlookApp.CreateItem(0)
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'These are the ranges being emailed.
ActiveSheet.Range(blahblahblah).Select
'Intro is the first line of the email
Intro = "BLAHBLAHBLHA"
'Set the To and Subject lines. Send the message.
With OutMail
.To = "blahblah#blah.com"
.Subject = "More BLAH here"
.HTMLBody = Intro & RangetoHTML(Selection)
.Send
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
ActiveSheet.Range("A1").Select
ActiveWindow.ScrollColumn = ActiveCell.Column
ActiveWindow.ScrollRow = ActiveCell.Row
Set OutMail = Nothing
Set mOutlookApp = Nothing
Exit Sub
ErrorHandler:
Set mOutlookApp = CreateObject("Outlook.application")
Resume Next
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Why do you explicitly specify the version? Why not simply
Set emailOutlookApp = CreateObject("Outlook.Application")
Try "Outlook.Application.14". Not sure if this is related though: 2007 to 2010 upgrade issue
I realize it's not the exact issue, but it may lead you down the right path.