vba excel combo box in userform - vba

Basically the module Onboarding is asking the path of the tracker i want to update. I am updating details in the
sheet1 of the tracker.
I am setting the values of fields in userform 'OnboardingForm' to blank(so that the values entered last time to the
form is not visible when I am opening the form this time.
Now I am opening the form 'OnboardingForm' and entering values in the subsequent fields.
I have put a check button in my userform 'OnboardingForm' which is invisible to the front end user.
Now in the tracker there is a sheet named 'Project Tracks' which has information of all current projects
Once the submit button is clicked the control will go to the tracker's 'Project Tracks' sheet. It will validate the
track entered in the userform 'OnboardingForm' with the tracks present in the tracker's 'Project Tracks' sheet. Once found the other details against that particular track will get fetched to the tracker's sheet1(this I have done so that I will not have to enter values manually to the userform 'OnboardingForm' so that the form looks simple). There are no chances of the track not
matching.
Now one command button new track has been put in my current userform 'OnboardingForm'. Once clicked this will take the control to
the userform2 'ProjectTracksForm'.This is basically put so that if I am adding a new track, the form takes the detail and enters in the
tracker's 'Project Tracks' sheet.
Question 1> My current userform's Track button is a combo box. How do I add values in the dropdown from the tracker's
'Project Tracker' sheet to the dropdown.
Question 2> Once I add a new track in userform2 'ProjectTracksForm',submit and then when I come back to my current
userform 'OnboardingForm' that added track should be shown in the dropdown of Track combo box.
Please find below my piece of code.
This is my module for onboarding
Public Sub OnBoarding()
On Error GoTo ErrorHandler
Dim Owb As Object
Dim ran As Range
strTalentTrackerPath = shTracker.Cells(2, 2).Value
'Default the form values to null
With OnboardingForm
.combTrackofWork.Value = ""
.txtFirstName.Text = ""
.txtLastName.Text = ""
.combResCat.Value = ""
.combBFTE.Value = ""
.combLevel.Value = ""
.combLocType = ""
.txtAccessInfo.Text = ""
End With
OnboardingForm.Show
SetFocus.combTrackofWork
With OnboardingForm
'Details to be entered in the form'
strTOW = Trim$(.combTrackofWork.Value)
strFN = Trim$(.txtFirstName.Text)
strLN = Trim$(.txtLastName.Text)
strResCat = Trim$(.combResCat.Value)
strBilFTE = Trim$(.combBFTE.Value)
strLevel = Trim$(.combLevel.Value)
strLocType = (.combLocType.Value)
strAccessInfo = (.txtAccessInfo.Text)
End With
If OnboardingForm.chkOKButtonClick = True Then
Set oExcel = New Excel.Application
strMyFolder = strTalentTrackerPath
Set Owb = oExcel.Workbooks.Open(strMyFolder)
IntRowCount = Owb.Sheets(1).UsedRange.Rows.Count
With Owb.Sheets(1)
With Owb.Sheets("Project Tracks")
IntTrackRowCount = .UsedRange.Rows.Count
For IntCurrentRow = 1 To IntTrackRowCount
If .Cells(IntCurrentRow, 1) = strTOW Then
Owb.Sheets(1).Cells(IntRowCount + 1, OnboardingFormcolumn.colTrackofWork) _
= .Cells(IntCurrentRow, ProjectTrackscolumn.colTrack)
Owb.Sheets(1).Cells(IntRowCount + 1, OnboardingFormcolumn.colBPO) = .Cells _
(IntCurrentRow, ProjectTrackscolumn.colBPO)
Owb.Sheets(1).Cells(IntRowCount + 1, OnboardingFormcolumn.colCostCenter) _
= .Cells(IntCurrentRow, ProjectTrackscolumn.colCostCenter)
Owb.Sheets(1).Cells(IntRowCount + 1, OnboardingFormcolumn.colGroup) _
= .Cells(IntCurrentRow, ProjectTrackscolumn.colGroup)
Exit For
End If
Next
End With
End With
.Cells(IntRowCount + 1, OnboardingFormcolumn.colTrackofWork) = strTOW
.Cells(IntRowCount + 1, OnboardingFormcolumn.colFirstName) = strFN
.Cells(IntRowCount + 1, OnboardingFormcolumn.colLastName) = strLN
.Cells(IntRowCount + 1, OnboardingFormcolumn.colResourceCategory) = strResCat
.Cells(IntRowCount + 1, OnboardingFormcolumn.colBilledFTE) = strBilFTE
.Cells(IntRowCount + 1, OnboardingFormcolumn.colLevel) = strLevel
.Cells(IntRowCount + 1, OnboardingFormcolumn.colLocationType) = strLocType
.Cells(IntRowCount + 1, OnboardingFormcolumn.colAccessInformation) = strAccessInfo
Owb.Close True
Set Owb = Nothing
Set oExcel = Nothing
Else
Exit Sub
End If
Exit Sub
ErrorHandler:
If Owb Is Nothing Then
Else
Owb.Close False
End If
If oExcel Is Nothing Then
Else
Set oExcel = Nothing
End If
MsgBox "Unhandled Error. Please Report" & vbCrLf & "Error Description: " & _
Err.Description, vbExclamation
End Sub
This is for cancel button of Onboarding Form
Private Sub cmdbtn_Cancel_Click()
OnboardingForm.Hide
MsgBox ("No data entered")
End Sub
This is for OnboardingForm submit button
Private Sub cmdbtn_Submit_Click()
If Trim(OnboardingForm.combTrackOfWork.Value) = "" Then
OnboardingForm.combTOW.SetFocus
MsgBox ("Track of Work cannot be blank")
Exit Sub
End If
If Trim(OnboardingForm.txtFirstName.Value) = "" Then
OnboardingForm.txtFN.SetFocus
MsgBox ("First name cannot be blank")
Exit Sub
End If
If Trim(OnboardingForm.txtLastName.Value) = "" Then
OnboardingForm.txtLN.SetFocus
MsgBox ("Last name cannot be blank")
Exit Sub
End If
End Sub
Module for Project Tracks
Public Sub prjctTracks()
On Error GoTo ErrorHandler
Dim Owb As Object
strTalentTrackerPath = shTracker.Cells(2, 2).Value
With ProjectTracksForm
.txtTOW = ""
.txtBPO = ""
.txtCOCE = ""
.txtSOW = ""
.txtGroup = ""
End With
ProjectTracksForm.Show
With ProjectTracksForm
strTOW = Trim$(.txtTOW.Text)
strBPO = Trim$(.txtBPO.Text)
strCOCE = Trim$(.txtCOCE.Text)
strSOW = Trim$(.txtSOW.Value)
strGroup = Trim$(.txtGroup.Value)
End With
ProjectTracksForm.Hide
If ProjectTracksForm.chkbtn_OKclick = True Then
Set oExcel = New Excel.Application
strMyFolder = strTalentTrackerPath
Set Owb = oExcel.Workbooks.Open(strMyFolder)
With Owb.Sheets("Project Tracks")
intUsedRowCount = .UsedRange.Rows.Count
.Cells(intUsedRowCount + 1, Trackscolumn.colTrack) = strTOW
.Cells(intUsedRowCount + 1, Trackscolumn.colBPO) = strBPO
.Cells(intUsedRowCount + 1, Trackscolumn.colCostCenter) = strCOCE
.Cells(intUsedRowCount + 1, Trackscolumn.colSOW) = strSOW
.Cells(intUsedRowCount + 1, Trackscolumn.colGroup) = strGroup
End With
Owb.Close True
Set Owb = Nothing
Set oExcel = Nothing
Else
Exit Sub
End If
Exit Sub
ErrorHandler:
If Owb Is Nothing Then
Else
Owb.Close False
End If
If oExcel Is Nothing Then
Else
Set oExcel = Nothing
End If
MsgBox "Unhandled Error. Please Report" & vbCrLf & "Error Description: " & _
Err.Description, vbExclamation
End Sub

Question 1> My current userform's Track button is a combo box. How do
I add values in the dropdown from the tracker's 'Project Tracker'
sheet to the dropdown.
I am calling the combobox "ComboBox1" in this example
The Range to place in the combobox would look like this...
The code to populate the combobox would be in the Userform Module.
Private Sub UserForm_Initialize()
Dim LstRw As Long
Dim Rng As Range
Dim ws As Worksheet
Set ws = Sheets("Project Tracker")
With ws
LstRw = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Rng = .Range("A2:A" & LstRw)
End With
ComboBox1.List = Rng.Value
End Sub
Question 2> Once I add a new track in userform2
'ProjectTracksForm',submit and then when I come back to my current
userform 'OnboardingForm' that added track should be shown in the
dropdown of Track combo box
When you activate your userform again, you can clear the combobox and repopulate it with the new list.
Private Sub UserForm_Activate()
Dim LstRw As Long
Dim Rng As Range
Dim ws As Worksheet
Set ws = Sheets("Project Tracker")
With ws
LstRw = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Rng = .Range("A2:A" & LstRw)
End With
ComboBox1.Clear
ComboBox1.List = Rng.Value
End Sub
I assume that somewhere you would have a code that will add a new item to the List in sheet("Project Tracker"),
Something like:
Private Sub CommandButton1_Click()
'THIS IS IN THE OTHER USERFORM
'add item to first blank cell in column A sheets("Project Tracker")
Dim sh As Worksheet
Dim LstRws As Long
Set sh = Sheets("Project Tracker")
With sh
LstRws = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Cells(LstRws, 1) = "SomeThingNew" 'whatever you are adding to the list
End With
End Sub
The code will add something new to the list in your worksheet.
When you show the form again, the new item will be in the combobox.
You can either use a Button, Combobox event, textbox event, to add the item to the new list.

Related

Inserting values from a UserForm to excel sheet which start from a fixed cell?

I have a Cell range Sheets("INVOICE MAKER").Range("D18:D37") (Total 20 Cells), and a little UserForm with name Add Items.
In UserForm there are one Textbox and one Submit Button.
So if I write something in that Textbox and click on Submit Button, Data should be write to next available empty cell in range Sheets("INVOICE MAKER").Range("D18:D37"). And if all 20 cells are filled with data then show a message like "No more rows are available to write data".
Below code don't start writing data from Cell D18, its start writing data from D1.
and doesn't stop after cell D37.
Option Explicit
Dim lRow As Long
Dim ws As Worksheet
Set ws = Worksheets("INVOICE MAKER")
lRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
'check for a part number
If Trim(Me.Textbox.Value) = "" Then
Me.Textbox.SetFocus
MsgBox "Please Type Item Name"
Exit Sub
End If
With ws
.Cells(lRow, 5).Value = Me.Textbox.Value
End With
End Sub
Hope below code will help you:
Public Working_Sheet As Worksheet
Public All_Cell_Value As Boolean
Public Write_Cell_No As Integer
Public Content As String
'When button in the form is clicked
Sub Button1_Click()
Write_Content
End Sub
'validation and content writing function
Public Function Write_Content()
All_Cell_Value = True
Set Working_Sheet = Worksheets("Sheet1")
For i = 18 To 37
If Trim(Working_Sheet.Cells(i, "D")) = "" Then
All_Cell_Value = False
Write_Cell_No = i
Exit For
End If
Next i
If All_Cell_Value = False Then
Content = InputBox("Enter the value")
If Content = "" Then
MsgBox ("No Data")
Else
Working_Sheet.Cells(i, "D").Value = Content
End If
Else
MsgBox ("Sorry content is full")
End If
End Function
Maybe this will help!
EDIT #1
Fix some errors, and the code must to be inside a Form, with the TextBox and the Button
EDIT #2
Added a closing statement for the userform or the macro
Option Explicit
Private Sub CommandButton1_Click()
Dim lRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("INVOICE MAKER") 'Set from Thisworkbook
ws.Activate 'activate the Invoice Maker
'lRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
Dim iniCell As Integer: iniCell = 18
Dim endCell As Integer: endCell = 37
Dim setCol As Integer: setCol = ws.Range("D1").Column
'As you said, the range is D18:D37, then you can manipulate from this 3 vars
Dim iRange As Range
Dim i As Range
Dim isTheRangeFull As Boolean: isTheRangeFull = False
Dim iMsgbox As Integer
If Trim(Me.TextBox.Value) = "" Then
Me.TextBox.SetFocus
'Ask the user to retry or quit.
iMsgbox = MsgBox("Please Type Item Name" & Chr(10) & "Do you want to retry?", vbYesNo + vbDefaultButton1)
If iMsgbox = 6 Then
GoTo InsertData
'if the user say YES
'do it again
ElseIf iMsgbox = 7 Then
End
'if the user say NO
End If
End If
Set iRange = ws.Range(Cells(iniCell, setCol), Cells(endCell, setCol))
'set your working Range
'This Loop do the job!
For Each i In iRange
isTheRangeFull = True
'if there is no empty cell, won't enter the if, and
'the var continue TRUE, so there is no empty cells...
If i.Value = Empty Then
i.Value = Me.TextBox.Value
isTheRangeFull = False
'the Next line (End) Will close the Form and terminate the macro
'End
'The next line just close the userform
'Unload Me
'Decide which one to uncomment.
Exit For
End If
Next i
If isTheRangeFull Then
MsgBox "No more rows are available to write data"
End
End If
'With ws
' .Cells(lRow, 5).Value = Me.TextBox.Value
'End With
InsertData:
End Sub

How to make a range bar chart

Hey I'm new to forums and this is my first post. I am new to vba in excel, but have written thinkscript in ThinkorSwim.
If anyone is familiar with a range stock chart, thats what Im going after.
I found code for a line chart, and am using it, but it is based on where price is at any given time. I want to modify this line chart to only plot values when they are above or below a range so that it resembles a candlestick chart with no wicks. Once data enters that range, I only want it to update whenever a new high or low is made in that range. The ranges need to be preset (ex. 50 ticks) Once the range is exceeded, I want the data plotted in the next range up, and repeat the process. Time and dates should be ignored, and only plot based on price action.
Does anyone have any ideas?
Option Explicit
'Update the values between the quotes here:
Private Const sChartWSName = "Chart"
Private Const sSourceWSName = "Sheet1"
Private Const sTableName = "tblValues"
Public RunTime As Double
Private Sub Chart_Setup()
'Create the structure needed to preserve and chart data
Dim wsChart As Worksheet
Dim lstObject As ListObject
Dim cht As Chart
Dim shp As Button
'Create sheet if necessary
Set wsChart = Worksheets.Add
wsChart.Name = sChartWSName
'Set up listobject to hold data
With wsChart
.Range("A1").Value = "Time"
.Range("B1").Value = "Value"
Set lstObject = .ListObjects.Add( _
SourceType:=xlSrcRange, _
Source:=.Range("A1:B1"), _
xllistobjecthasheaders:=xlYes)
lstObject.Name = sTableName
.Range("A2").NumberFormat = "h:mm:ss AM/PM (mmm-d)"
.Columns("A:A").ColumnWidth = 25
.Select
End With
'Create the chart
With ActiveSheet
.Shapes.AddChart.Select
Set cht = ActiveChart
With cht
.ChartType = xlLine
.SetSourceData Source:=Range(sTableName)
.PlotBy = xlColumns
.Legend.Delete
.Axes(xlCategory).CategoryType = xlCategoryScale
With .SeriesCollection(1).Format.Range
.Visible = msoTrue
.Weight = 1.25
End With
End With
End With
'Add buttons to start/stop the routine
Set shp = ActiveSheet.Buttons.Add(242.25, 0, 83.75, 33.75)
With shp
.OnAction = "Chart_Initialize"
.Characters.Text = "Restart Plotting"
End With
Set shp = ActiveSheet.Buttons.Add(326.25, 0, 83.75, 33.75)
With shp
.OnAction = "Chart_Stop"
.Characters.Text = "Stop Plotting"
End With
End Sub
Public Sub Chart_Initialize()
'Initialize the routine
Dim wsTarget As Worksheet
Dim lstObject As ListObject
'Make sure worksheet exists
On Error Resume Next
Set wsTarget = Worksheets(sChartWSName)
If Err.Number <> 0 Then
Call Chart_Setup
Set wsTarget = Worksheets(sChartWSName)
End If
On Error GoTo 0
'Check if chart data exists
With Worksheets(sChartWSName)
Set lstObject = .ListObjects(sTableName)
If lstObject.ListRows.Count > 0 Then
Select Case MsgBox("You already have data. Do you want to clear it and start fresh?", vbYesNoCancel, "Clear out old data?")
Case Is = vbYes
'User wants to clear the data
lstObject.DataBodyRange.Delete
Case Is = vbCancel
'User cancelled so exit routine
Exit Sub
Case Is = vbNo
'User just wants to append to existing table
End Select
End If
'Begin appending
Call Chart_AppendData
End With
End Sub
Private Sub Chart_AppendData()
'Append data to the chart table
Dim lstObject As ListObject
Dim lRow As Long
With Worksheets(sChartWSName)
Set lstObject = .ListObjects(sTableName)
If lstObject.ListRows.Count = 0 Then
lRow = .Range("A1").End(xlDown).Row
End If
If lRow = 0 Then
lRow = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
End If
If lRow > 2 Then
If .Range("B" & lRow - 1).Value = Worksheets(sSourceWSName).Range("C10").Value Then
'Data is a match, so do nothing
Else
'Data needs appending
.Range("A" & lRow).Value = CDate(Now)
.Range("B" & lRow).Value = Worksheets(sSourceWSName).Range("C10").Value
End If
Else
'Data needs appending
.Range("A" & lRow).Value = CDate(Now)
.Range("B" & lRow).Value = Worksheets(sSourceWSName).Range("C10").Value
End If
End With
RunTime = Now + TimeValue("00:00:01")
Application.OnTime RunTime, "Chart_AppendData"
End Sub
Public Sub Chart_Stop()
'Stop capturing data
On Error Resume Next
Application.OnTime EarliestTime:=RunTime, Procedure:="Chart_AppendData", Schedule:=False
End Sub
Take your sheet of data and filter... example would be:
Columns("A:C").Sort key1:=Range("C2"), _
order1:=xlAscending, header:=xlYes
Sort info: https://msdn.microsoft.com/en-us/library/office/ff840646.aspx
You then can define to select your desired range. Assuming column A is x-axis and B is y-axis (where your parameters for modifying need to be assessed):
Dim High1 as integer
Dim Low1 as integer
High1 = Match(Max(B:B),B:B) 'This isn't tested, just an idea
Low1 = Match(Max(B:B)+50,B:B) 'Again, not tested
and using those defined parameters:
.Range(Cells(High1,1),Cells(Low1,2).Select
This should give an idea for High1/Low1, where you can work through how you want to define the row that the max value occurs.
You then CreateObject for the Chart you want, having selected the data range you are going to use.

Excel/VBA Macros assistance

I am having a bit of trouble with some code and was wondering if someone could maybe assist. Basically I have 2 errors which I can't work out myself (too inexperienced with VBA, unfortunately)
Brief overview:
This macro is designed to generate a new workbook with copies of selected sheets from a "source" workbook in order to present to clients as a report batch. Essentially - we have master workbook "A" which may have 50 tabs or so, and we want to quickly select a couple of sheets to "copy" into a new workbook to save and send to a client. The code is a bit of a mess but I am not really sure what is going on/what I can remove etc.
Problems:
When you run the attached code/macro in Excel, it does everything it is supposed to do, however, it ALSO copies the sheet from which you run the macro. (i.e. I might be on sheet 1 in the Workbook. Run the macro to generate reports, checkbox menu appears and I select sheets 2, 5 & 9 - it will then copy into a new Workbook sheets 2, 5 & 9 AND sheet 1. But I never selected sheet 1 from the checkbox menu...)
Once this code has finished running, I am unable to save the Excel file. It just crashes and says "Microsoft Excel has stopped working" and then the file dies and I have to close Excel and recover etc. etc. I combined 2 pieces of code to get this working and I imagine I may be missing something crucial which is causing the problem. We have another piece of code to print sheets out in a similar way to this, and if I run this I am able to save with no problems.
Code:
I have included all the Visual Basic code (i.e. for the generate reports & print sheets macros).
I really don't have any experience with VBA so I hope someone will be able to assist! Thanks in advance :)
Sub PrintSelectedSheets()
Dim i As Integer
Dim TopPos As Integer
Dim SheetCount As Integer
Dim Printdlg As DialogSheet
Dim CurrentSheet As Worksheet, wsStartSheet As Worksheet
Dim CB As CheckBox
Application.ScreenUpdating = False
'Check for protected workbook
If ActiveWorkbook.ProtectStructure Then
MsgBox "Workbook is protected.", vbCritical
Exit Sub
End If
'Add a temporary dialog sheet
Set CurrentSheet = ActiveSheet
Set wsStartSheet = ActiveSheet
Set Printdlg = ActiveWorkbook.DialogSheets.Add
SheetCount = 0
'Add the checkboxes
TopPos = 40
For i = 1 To ActiveWorkbook.Worksheets.Count
Set CurrentSheet = ActiveWorkbook.Worksheets(i)
'Skip empty sheets and hidden sheets
If Application.CountA(CurrentSheet.Cells) <> 0 And _
CurrentSheet.Visible Then
SheetCount = SheetCount + 1
Printdlg.CheckBoxes.Add 78, TopPos, 150, 16.5
Printdlg.CheckBoxes(SheetCount).Text = _
CurrentSheet.Name
TopPos = TopPos + 13
End If
Next i
'Move the OK and Cancel buttons
Printdlg.Buttons.Left = 240
'Set dialog height, width, and caption
With Printdlg.DialogFrame
.Height = Application.Max _
(68, Printdlg.DialogFrame.Top + TopPos - 34)
.Width = 230
.Caption = "Select sheets to print"
End With
'Change tab order of OK and Cancel buttons
'so the 1st option button will have the focus
Printdlg.Buttons("Button 2").BringToFront
Printdlg.Buttons("Button 3").BringToFront
'Display the dialog box
CurrentSheet.Activate
wsStartSheet.Activate
Application.ScreenUpdating = True
If SheetCount <> 0 Then
'the following code will print the selected sheets as multiple print jobs.
'continuous page numbers will therefore not be printed
If Printdlg.Show Then
For Each CB In Printdlg.CheckBoxes
If CB.Value = xlOn Then
Worksheets(CB.Caption).Activate
ActiveSheet.PrintOut
'ActiveSheet.PrintPreview 'for debugging
End If
Next CB
'the following code will print the selected sheets as a single print job.
'This will allow the sheets to be printed with continuous page numbers.
'If Printdlg.Show Then
'For Each CB In Printdlg.CheckBoxes
'If CB.Value = xlOn Then
'Worksheets(CB.Caption).Select Replace:=False
'End If
'Next CB
'ActiveWindow.SelectedSheets.PrintOut copies:=1
'ActiveSheet.Select
Else
MsgBox "No worksheets selected"
End If
'End If
End If
'Delete temporary dialog sheet (without a warning)
Application.DisplayAlerts = False
Printdlg.Delete
'Reactivate original sheet
CurrentSheet.Activate
wsStartSheet.Activate
End Sub
Sub GenerateClientExcelReports()
'1. Declare variables
Dim i As Integer
Dim SheetCount As Integer
Dim TopPos As Integer
Dim lngCheckBoxes As Long, y As Long
Dim intTopPos As Integer, intSheetCount As Integer
Dim intHor As Integer 'this will be for the horizontal position of the items
Dim intWidth As Integer 'this will be for the overall width of the dialog box
Dim intLBLeft As Integer, intLBTop As Integer, intLBHeight As Integer
Dim Printdlg As DialogSheet
Dim CurrentSheet As Worksheet, wsStartSheet As Worksheet
Dim CB As CheckBox
'Dim wb As Workbook
'Dim wbNew As Workbook
'Set wb = ThisWorkbook
'Workbooks.Add ' Open a new workbook
'Set wbNew = ActiveWorkbook
On Error Resume Next
Application.ScreenUpdating = False
'2. Check for protected workbook
If ActiveWorkbook.ProtectStructure Then
MsgBox "Workbook is protected.", vbCritical
Exit Sub
End If
'3. Add a temporary dialog sheet
Set CurrentSheet = ActiveSheet
Set wsStartSheet = ActiveSheet
Set Printdlg = ActiveWorkbook.DialogSheets.Add
SheetCount = 0
'4. Add the checkboxes
TopPos = 40
For i = 1 To ActiveWorkbook.Worksheets.Count
Set CurrentSheet = ActiveWorkbook.Worksheets(i)
'5. Skip empty sheets and hidden sheets
If Application.CountA(CurrentSheet.Cells) <> 0 And _
CurrentSheet.Visible Then
SheetCount = SheetCount + 1
Printdlg.CheckBoxes.Add 78, TopPos, 150, 16.5
Printdlg.CheckBoxes(SheetCount).Text = _
CurrentSheet.Name
TopPos = TopPos + 13
End If
Next i
'6. Move the OK and Cancel buttons
Printdlg.Buttons.Left = 240
'7. Set dialog height, width, and caption
With Printdlg.DialogFrame
.Height = Application.Max _
(68, Printdlg.DialogFrame.Top + TopPos - 34)
.Width = 230
.Caption = "Select sheets to generate"
End With
'8. Change tab order of OK and Cancel buttons
' so the 1st option button will have the focus
Printdlg.Buttons("Button 2").BringToFront
Printdlg.Buttons("Button 3").BringToFront
'9. Display the dialog box
CurrentSheet.Activate
wsStartSheet.Activate
Application.ScreenUpdating = True
If SheetCount <> 0 Then
If Printdlg.Show Then
For Each CB In Printdlg.CheckBoxes
If CB.Value = xlOn Then
Worksheets(CB.Caption).Select Replace:=False
'For y = 1 To ActiveWorkbook.Worksheets.Count
'If WorksheetFunction.IsNumber _
'(InStr(1, "ActiveWorkbook.Sheets(y)", "Contents")) = True Then
'CB.y = xlOn
'End If
End If
Next
ActiveWindow.SelectedSheets.Copy
Else
MsgBox "No worksheets selected"
End If
End If
'Delete temporary dialog sheet (without a warning)
'Application.DisplayAlerts = False
'Printdlg.Delete
'Reactivate original sheet
'CurrentSheet.Activate
'wsStartSheet.Activate
'10. Delete temporary dialog sheet (without a warning)
Application.DisplayAlerts = False
Printdlg.Delete
'11. Reactivate original sheet
CurrentSheet.Activate
wsStartSheet.Activate
Application.DisplayAlerts = True
End Sub
Sub SelectAllCheckBox()
Dim CB As CheckBox
For Each CB In ActiveSheet.CheckBoxes
If CB.Name <> ActiveSheet.CheckBoxes(1).Text Then
CB.Value = ActiveSheet.CheckBoxes(1).Value
End If
Next CB
'ActiveSheet.CheckBoxes("Check Box 1").Value
End Sub
as for problem n°1
add a declaration of a boolean variable
Dim firstSelected As Boolean
and then modify the For Each CB In Printdlg.CheckBoxes loop block code as follows
If CB.Value = xlOn Then
If firstSelected Then
Worksheets(CB.Caption).Select Replace:=False
Else
Worksheets(CB.Caption).Select
firstSelected = True
End If
'For y = 1 To ActiveWorkbook.Worksheets.Count
'If WorksheetFunction.IsNumber _
'(InStr(1, "ActiveWorkbook.Sheets(y)", "Contents")) = True Then
'CB.y = xlOn
'End If
End If
since there's always an ActiveWorksheet when macro starts and thus if you only use Worksheets(CB.Caption).Select Replace:=False statement you keep adding it to the via Printdlg selected sheets.

Choose from Excel dropdown programmatically

I want to write a macro that will pick a particular value (in my case, stored in cell A1) from a dropdown list (in my case, in cell D6).
Here's what I have so far:
sr_par2 = Array ("TEXT", 'TEXT2", "TEXT3")
sr = Range("A1").Value
(...)
Dim i As Integer
i = 0
Range("D6").Select
Do While (sr <> ActiveCell.FormulaR1C1)
Range("D6").Select
ActiveCell.FormulaR1C1 = sr_par2(i)
i = i + 1
Loop
Is this what you are trying? I have commented the code so that you will not have a problem understanding it. Still if you do then simply ask :)
Sub Sample()
Dim ws As Worksheet
Dim rngIn As Range, rngOut As Range
Dim MyAr
Dim sFormula As String
Dim i As Long
'~~> Replace this with the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Set your input and output range here
Set rngIn = .Range("A1")
Set rngOut = .Range("D6")
'~~> Get the validation list if there is one
On Error Resume Next
sFormula = rngOut.Validation.Formula1
On Error GoTo 0
If sFormula = "" Then
'~~> If no validation list then directly populate the value
rngOut.Value = rngIn.Value
Else
'validation list TEXT1,TEXT2,TEXT3
MyAr = Split(sFormula, ",")
'~~> Loop through the list and compare
For i = LBound(MyAr) To UBound(MyAr)
If UCase(Trim(rngIn.Value)) = UCase(Trim(MyAr(i))) Then
rngOut.Value = MyAr(i)
Exit For
End If
Next i
'~~> Check if the cell is still blank. If it is then it means that
'~~> Cell A1 has a value which is not part of the list
If Len(Trim(rngOut.Value)) = 0 Then
MsgBox "The value in " & rngOut.Address & _
" cannot be set as the value you are copying is not part of the list"
End If
End If
End With
End Sub
If I understood correctly, this should do what you want :
sr_par2 = Array("TEXT", "TEXT2", "TEXT3")
sr = Range("A1").Value
Dim i As Integer
i = 0
On Error GoTo Handler
Do While (sr <> sr_par2(i))
i = i + 1
Loop
Range("D6").FormulaR1C1 = sr_par2(i)
Exit Sub
Handler:
MsgBox "Value not in the list", vbCritical + vbOKOnly, "Value not found"

VBA - Open form within loop then wait for OK click

I have a script that checks for new shops in a sheet. If it finds a new shop it should open a form and prompt the user to select a shop category and then click ok. When the the user clicks ok the value from the dropdown should be selected and then form closes and the loop continues.
The form is calles "shopkat"
This is how it works:
For i = LBound(distshops) To UBound(distshops)
If Not IsEmpty(distshops(i)) Then
curcell = getrows
curshop = distshops(i)
findout = checkifinsheet(curshop)
If findout = False Then
Cells(curcell + 1, 1) = curshop
'show form
shopkat.Show vbModal
'shop current shop
shopkat.shop.Caption = curshop
'Get value from combo
Cells(curcell + 1, 2) = shopkat.shopkatcombo.value
'if user click ok then continue
End If
End If
Next i
Could anyone help. Thanks a lot!
//////////////////////////// Updated ///////////////////////////////
Module1:
Public curcell As Long
Dim ws As Worksheet
Form shopkat:
Private Sub shopkatok_Click()
If Not shopkat.shopkatcombo.value = "" Then
ws.Cells(curcell + 1, 2) = shopkat.shopkatcombo.value
Unload Me
End If
End Sub
Loop Sheet(Shopcategories)
Set ws = ThisWorkbook.Sheets("Shopcategories")
For i = LBound(distshops) To UBound(distshops)
If Not IsEmpty(distshops(i)) Then
curcell = getrows()
curshop = distshops(i)
findout = checkifinsheet(curshop)
If findout = False Then
shopkat.shop.Caption = curshop
'show form
shopkat.Show
If Not IsEmpty(Cells(curcell + 1, 2).value) Then
ws.Cells(curcell + 1, 1) = curshop
End If
End If
End If
Next i
Ok Do this. (UNTESTED)
A) Insert a module and paste these lines
Public curcell As Long
Dim ws as Worksheet
B) Next in the Userform's Ok Button paste this code
Private Sub CommandButton1_Click()
ws.Cells(curcell + 1, 2) = shopkat.shopkatcombo.Value
Unload Me
End Sub
C) And lastly amend your above code to this
Sub Sample()
'
'~~> Rest of code
'
'~~> Change this as a applicable
Set ws = ThisWorkbook.Sheets("Sheet1")
For i = LBound(distshops) To UBound(distshops)
If Not IsEmpty(distshops(i)) Then
curcell = getrows
curshop = distshops(i)
findout = checkifinsheet(curshop)
If findout = False Then
ws.Cells(curcell + 1, 1) = curshop
shopkat.shop.Caption = curshop
'show form
shopkat.Show '<~~ No need to mention vbModal. It is default
End If
End If
Next i
'
'~~> Rest of code
'
End Sub