I have a excel form which works and saves data to just one worksheet. I like to be able to put a radio button and based on that selection i like to save to a diffent work sheet.
example:
if radio button 1 is selected save to sheet1
if radio button 2 is selected save to sheet2
if radio button 3 is selected save to sheet3
same form used to save on different worksheet.
the code im working with.
Private Sub btn_append_Click()
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Assessment")
'find first empty row in database
iRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
'check for a part number
If Trim(Me.txt_roomNumber.Value) = "" Then
Me.txt_roomNumber.SetFocus
MsgBox "Please enter a Room Number"
Exit Sub
End If
'copy the data to the database
'use protect and unprotect lines,
' with your password
' if worksheet is protected
With ws
' .Unprotect Password:="password"
.Cells(iRow, 1).Value = Me.txt_roomNumber.Value
.Cells(iRow, 2).Value = Me.txt_roomName.Value
.Cells(iRow, 3).Value = Me.txt_department.Value
.Cells(iRow, 4).Value = Me.txt_contact.Value
.Cells(iRow, 5).Value = Me.txt_altContact.Value
.Cells(iRow, 6).Value = Me.cbx_devices.Value
.Cells(iRow, 7).Value = Me.cbx_wallWow.Value
.Cells(iRow, 8).Value = Me.txt_existingHostName.Value
.Cells(iRow, 10).Value = Me.cbx_relocate.Value
If Me.ckb_powerbar.Value = True Then Cells(iRow, 11).Value = "Y"
If Me.ckb_dataJackPull.Value = True Then Cells(iRow, 12).Value = "P"
.Cells(iRow, 13).Value = Me.txt_existingDataJack.Value
If Me.ckb_hydroPull.Value = True Then Cells(iRow, 14).Value = "P" Else Cells(iRow, 14).Value = "A"
.Cells(iRow, 19).Value = Me.txt_cablePullDesc.Value
.Cells(iRow, 20).Value = Me.txt_hydroPullDesc.Value
.Cells(iRow, 21).Value = Me.Txt_otherDesc.Value
' .Protect Password:="password"
End With
'clear the data
'Me.txt_roomNumber.Value = ""
'Me.txt_roomName.Value = ""
'Me.txt_department.Value = ""
'Me.txt_contact.Value = ""
'Me.txt_altContact.Value = ""
Me.cbx_relocate.Value = ""
Me.txt_existingHostName = ""
Me.txt_altContact.SetFocus
End Sub
Private Sub btn_close_Click()
Unload Me
End Sub
Private Sub ComboBox1_Change()
End Sub
Private Sub UserForm_Click()
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
MsgBox "Please use the Close Form button!"
End If
End Sub
The first thing to do is to add the radio-buttons (actually OptionButton) to the form and name them.
Then to check if one of them is selected use code such as:
If optSheet1 Then
'it is checked
ElseIf optSheet2 Then
'the second one is checked
'etc
End If
Related
I use the following code assigned to a CommandButton to automatically attach the workbook to an email so users can send it out. Is there a way to attach the workbook without the code, so the people receiving the email do not have the full code, but the sender keeps it in their copy? (The recipients only need to see the data, they do not interact with the form, but the sender interacts with it several times a day.) When I save the Workbook as .xlsx, it gives me an yes/no/help MsgBox that I would like to avoid during the sending - to keep it as a "one-click" operation.
Source_File = ThisWorkbook.FullName
myMail.Attachments.Add Source_File
Option Explicit
Sub CDO_Mail_Workbook()
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim iMsg As Object
Dim iConf As Object
Dim Flds As Variant
Dim MyDate
MyDate = Format(Now(), "dd-mmm-yy")
Set wb = ActiveWorkbook
If Val(Application.Version) >= 12 Then
If wb.FileFormat = 51 And wb.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file, there will be no VBA code in the file you send." & vbNewLine & _
"Save the file first as xlsm and then try the macro again.", vbInformation
Exit Sub
End If
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Make a copy of the file/Mail it/Delete it
'If you want to change the file name then change only TempFileName
TempFilePath = Environ$("temp") & "\"
'TempFileName = wb.Name & " " & Format(Now, "yyyy-mmm-dd")
TempFileName = "Test" & "-" & Format(Now, "yyyy-mmm-dd")
'FileExtStr = "." & LCase(Right(wb.Name, Len(wb.Name) - InStrRev(wb.Name, ".", , 1)))
FileExtStr = ".xlsm"
Application.DisplayAlerts = False
' wb.SaveAs Filename:=TempFilePath & TempFileName & FileExtStr, FileFormat:=51, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
ActiveWorkbook.SaveCopyAs Filename:=TempFilePath & TempFileName & "Copy" & FileExtStr
Workbooks.Open (TempFilePath & TempFileName & "Copy" & FileExtStr)
ActiveWorkbook.SaveAs Filename:=TempFilePath & TempFileName & "-email" & ".xlsx", FileFormat:=51, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
ActiveWorkbook.Close False
'wb.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Application.DisplayAlerts = True
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "noone#noone.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With
With iMsg
Set .Configuration = iConf
'.To = "noone#noone.com"
'.CC = ""
.BCC = ""
.From = "noone#noone.com"
.Subject = "Test - " & MyDate
.TextBody = ""
.AddAttachment TempFilePath & TempFileName & "-email" & ".xlsx"
.Send
End With
'If you not want to delete the file you send delete this line
Kill TempFilePath & TempFileName & "-email" & ".xlsx"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Application.DisplayAlerts = False
Set wb = Nothing
For Each wb In Application.Workbooks
wb.Save
Next wb
Application.Quit
End Sub
To send a single worksheet with the vba code removed, I've used this:
Option Explicit
'This procedure will send the ActiveSheet in a new workbook
'For more sheets use : Sourcewb.Sheets(Array("Sheet1", "Sheet3")).Copy
Sub CDO_Mail_ActiveSheet_Or_Sheets()
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim iMsg As Object
Dim iConf As Object
Dim sh As Worksheet
Dim Flds As Variant
Dim MyDate
MyDate = Format(Now(), "dd-mmm-yy")
Dim wb As Workbook
Set wb = ActiveWorkbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
'Or if you want to copy more then one sheet use:
'Sourcewb.Sheets(Array("Sheet1", "Sheet3")).Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
'We exit the sub when your answer is NO in the security dialog that you only
'see when you copy a sheet from a xlsm file with macro's disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
'Change all cells in Destwb to values if you want
For Each sh In Destwb.Worksheets
sh.Select
With sh.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
Next sh
Destwb.Worksheets(1).Select
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Test" & "-" & Format(Now, "yyyy-mmm-dd")
Application.DisplayAlerts = False
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
.Close savechanges:=False
End With
Application.DisplayAlerts = True
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "noone#noone.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With
With iMsg
Set .Configuration = iConf
.To = "noone#noone.com"
'.CC = ""
'.BCC = ""
.From = "noone#noone.com"
.Subject = "Test-" & MyDate
.TextBody = ""
.AddAttachment TempFilePath & TempFileName & FileExtStr
.Send
End With
'If you not want to delete the file you send delete this line
Kill TempFilePath & TempFileName & FileExtStr
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Application.DisplayAlerts = False
Set wb = Nothing
For Each wb In Application.Workbooks
wb.Save
Next wb
Application.Quit
End Sub
Okay so when I press a specific button I want to loop through all forms, then find every control in each form with the tag 'TESTING'. If the tag = 'TESTING' then I want to change the caption of the object to 'abc123'.
The only objects with the tag 'TESTING' will be labels, so they will have the caption property.
So far I have this as the function:
Public Function changelabel()
On Error Resume Next
Dim obj As AccessObject, dbs As Object
Dim ctrl as Control
Set dbs = Application.CurrentProject
For Each obj In dbs.AllForms
DoCmd.OpenForm obj.Name, acDesign
For Each ctrl In Me.Controls
If ctrl.Tag = "TESTING" Then
ctrl.Caption = "abc123"
End If
Next ctrl
Next obj
End Function
Then this as the button code:
Public Sub TestButton_Click()
Call changelabel
End Sub
So it executes the first for loop and opens all the forms in design view correctly. The problem lies with the second for loop. None of the label captions that have the tag property as 'TESTING' are changed to 'abc123'.
So what do I need to change to get the second for loop to work?
Public Sub GetForms()
Dim oForm As Form
Dim nItem As Long
Dim bIsLoaded As Boolean
For nItem = 0 To CurrentProject.AllForms.Count - 1
bIsLoaded = CurrentProject.AllForms(nItem).IsLoaded
If Not bIsLoaded Then
On Error Resume Next
DoCmd.OpenForm CurrentProject.AllForms(nItem).NAME, acDesign
End If
Set oForm = Forms(CurrentProject.AllForms(nItem).NAME)
GetControls oForm
If Not bIsLoaded Then
On Error Resume Next
DoCmd.Close acForm, oForm.NAME
End If
Next
End Sub
Sub GetControls(ByVal oForm As Form)
Dim oCtrl As Control
Dim cCtrlType, cCtrlCaption As String
For Each oCtrl In oForm.Controls
If oCtrl.ControlType = acSubform Then Call GetControls(oCtrl.Form)
Select Case oCtrl.ControlType
Case acLabel: cCtrlType = "label": cCtrlCaption = oCtrl.Caption
Case acCommandButton: cCtrlType = "button": cCtrlCaption = oCtrl.Caption
Case acTextBox: cCtrlType = "textbox": cCtrlCaption = oCtrl.Properties("DataSheetCaption")
Case Else: cCtrlType = ""
End Select
If cCtrlType <> "" Then
Debug.Print oForm.NAME
Debug.Print oCtrl.NAME
Debug.Print cCtrlType
Debug.Print cCtrlCaption
End If
Next
End Sub
Something like this
Public Function changelabel()
Dim f As Form
Dim i As Integer
Dim c As Control
For i = 0 To CurrentProject.AllForms.Count - 1
If Not CurrentProject.AllForms(i).IsLoaded Then
DoCmd.OpenForm CurrentProject.AllForms(i).Name, acDesign
End If
Set f = Forms(i)
For Each c In f.Controls
If c.Tag = "TESTING" Then
c.Caption = "TESTING"
End If
Next c
Next i
End Function
You'll need to add a bit of house-keeping to set the objects used to nothing etc..
Basically what I am trying to do is, sending an email for every used row on the target worksheet, each row has the details of the addresses, subject line, table with values etc.
So I can't seem to get it working, as it only dispatches one email from the first target row (2nd row).
I have tried using a combination of For Each and For i = 1 to LR which aren't working. I suspect it is to do with the cell references.
Here is the code:
Sub TestEmail1()
Application.ScreenUpdating = False
Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim ccAddresses As Range, ccCell As Range, ccRecipients As String
Dim rngeSubject As Range, SubjectCell As Range, SubjectContent As Variant
Dim rngeBody As Range, bodyCell As Range, bodyContent As Variant
Dim Table1 As Range
Dim i As Integer
For Each c In ActiveSheet.UsedRange.Columns("A").Cells
Set rng = ActiveSheet.UsedRange
LRow = rng.Rows.Count
For i = 2 To LRow
Set Table1 = Worksheets(1).Range("K1:R1")
Set Table2 = Worksheets(2).Range("K" & i & ":" & "R" & i)
Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)
'set sheet to find address for e-mails as I have several people to
'mail to
Set rngeAddresses = ActiveSheet.Range("B" & i)
For Each rngeCell In rngeAddresses.Cells
strRecipients = strRecipients & ";" & rngeCell.Value
Next
Set ccAddresses = ActiveSheet.Range("C" & i)
For Each ccCell In ccAddresses.Cells
ccRecipients = ccRecipients & ";" & ccCell.Value
Next
Set rngeSubject = ActiveSheet.Range("D" & i)
For Each SubjectCell In rngeSubject.Cells
SubjectContent = SubjectContent & SubjectCell.Value
Next
Set rngeBody = ActiveSheet.Range("E" & i)
For Each bodyCell In rngeBody.Cells
bodyContent = bodyContent & bodyCell.Value
Next
'set Importance
'aEmail.Importance = 2
'Set Subject
aEmail.Subject = rngeSubject
'Set Body for mail
'aEmail.Body = bodyContent
aEmail.HTMLBody = bodyContent & "<br><br><br>" & RangetoHTML_ (Table1)
aEmail.To = strRecipients
aEmail.CC = ccRecipients
aEmail.Send
Exit Sub
Next i
Next c
End Sub
There is an Exit Sub at the end of your inner loop that makes the code exit from the procedure after the first iteration:
Sub TestEmail1()
...
For Each c In ActiveSheet.UsedRange.Columns("A").Cells
...
For i = 2 To LRow
...
Exit Sub
Next i
Next c
End Sub
Remove it and processing should continue as desired.
I have a form in which you introduce the product code and it returns its description and price. I would like to add another search criteria to be able to look for the product by keyword, searching in the "description" column. I'm not sure whether the "find" function allows doing this, or if I need to use the "vlookup" function. The problem that I found with "vlookup" is that I would like to be able to keep searching in the column for the rest of the matchs. This is the code that I have working at the moment:
Option Explicit
Dim Llave As Boolean
Private Sub BtnBuscar_Click()
If Not Sheet1.Range("C1:C211").Find(Me.DatoBuscado, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
If Llave Then
Cells.FindNext(After:=ActiveCell).Select
Fila.Caption = ActiveCell.Row
Dato1.Caption = ActiveCell.Value
Dato2.Caption = ActiveCell.Offset(0, 1).Value
Dato3.Caption = ActiveCell.Offset(0, 2).Value
Dato4.Caption = ActiveCell.Offset(0, 4).Value
Else
Sheet1.Range("C1:C211").Find(Me.DatoBuscado, LookIn:=xlValues, LookAt:=xlWhole).Select
Fila.Caption = Sheet1.Range("C:C").Find(Me.DatoBuscado, LookIn:=xlValues, LookAt:=xlWhole).Row
Dato1.Caption = Sheet1.Range("C:C").Find(Me.DatoBuscado, LookIn:=xlValues, LookAt:=xlWhole).Value
Dato2.Caption = Sheet1.Range("C:C").Find(Me.DatoBuscado, LookIn:=xlValues, LookAt:=xlWhole).Offset(0, 1).Value
Dato3.Caption = Sheet1.Range("C:C").Find(Me.DatoBuscado, LookIn:=xlValues, LookAt:=xlWhole).Offset(0, 2).Value
Dato4.Caption = Sheet1.Range("C:C").Find(Me.DatoBuscado, LookIn:=xlValues, LookAt:=xlWhole).Offset(0, 4).Value
Llave = True
End If
Else
Dato1.Caption = " "
Dato2.Caption = " "
Dato3.Caption = " "
Dato4.Caption = " "
Fila.Caption = " "
MsgBox "Dato Inexistente", 64, ""
End If
End Sub
Private Sub Dato1_Click()
End Sub
Private Sub Dato3_Click()
End Sub
Private Sub Fila_Click()
End Sub
Private Sub UserForm_Initialize()
Llave = False
End Sub
So it's a search form (Userform) that I pop up when clicking a button on the worksheet (shee1).
Thanks a lot in advance!
Natalia.
I would suggest using Find in a DO UNTIL loop until the range returned by find is nothing and use that loop to populate a listbox. Then the user can select the match that the want.
I have about 40 workbooks with 1000+ columns and near 1 million records.
Unfortunately, most of the data was imported as a text format, and I am trying to convert particular columns to a number format.
Aside from manually editing every file using the paste special > multiply technique, is there a way to macro this so that it would iterate through all the excel files in a particular folder?
You know the columns and numbers to change. You can record a macro of that and insert it into this basic DIR() technique:
Option Explicit
Sub LoopThroughFolder()
Dim fPATH As String, fNAME As String
Dim wb As Workbook
fPATH = "C:\Path\To\My\Files\" 'remember the final \
fNAME = Dir(fPATH & "*.xl*") 'get first filename from fPATH
Application.ScreenUpdating = False 'speed up execution
Do While Len(fNAME) > 0
Set wb = Workbooks.Open(fPATH & fNAME)
'your code here to format that activesheet
wb.Close True 'save and close the edited file
fNAME = Dir 'get the next filename
Loop
Application.ScreenUpdating = True
End Sub
Option Compare Database
Public Function format(filepath, sheetname, sheetpath)
Set xls = CreateObject("EXCEL.APPLICATION")
xls.screenupdating = False
xls.displayalerts = False
xls.Visible = True
xls.workbooks.Open filepath
Set xlsdd = xls.ActiveWorkbook
'deleting headers
xls.Range("1:1").Select
xls.Selection.Delete Shift:=xlUp
'adding one column
xls.Columns("A:A").Select
xls.Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'adding 5 rows
'ActiveWorkbook.Sheets("sheet1").Select
xls.Rows("1:5").Insert Shift:=xlDown
' fetching rows from access and putting them into excel
' strsql = "select top 5 " & sheetname & ".* into top5_records from " & sheetname
' DoCmd.RunSQL strsql
' outputFileName = "C:\Users\hp\Desktop\top5_records.xls"
' DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "top5_records", outputFileName, True
'then open that excel and copy the rows
Set xls2 = CreateObject("EXCEL.APPLICATION")
xls2.screenupdating = False
xls2.displayalerts = False
xls2.Visible = True
xls2.workbooks.Open sheetpath
Set xlsdd2 = xls2.ActiveWorkbook
xls2.Rows("1:5").Select
xls2.Selection.Copy
xls.Cells(1, 1).Select
xls.activesheet.Paste
'making first 6th row to be bold
xls.Rows("6:6").Select
With xls.Selection.Font
.Bold = True
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
End With
'autofit the data
xls.Sheets(sheetname).Cells.Columns.autofit
xls.CutCopyMode = False
'making both the excel objects to be free
With xlsdd
.Save
.Close
End With
xls.Visible = False
Set xlsdd = Nothing
Set xls = Nothing
With xlsdd2
.Save
.Close
End With
xls2.Visible = False
Set xlsdd2 = Nothing
Set xls2 = Nothing
End Function