How are you triggering the userform and what does your UserForm_Initialize() look like?
Posts by darkorder
-
-
First place I would check would be your defined variables. I recommend not setting them to 'DIM as Integer' or 'DIM as Long'. Change to 'DIM as LongPTR'.
-
You will need some way to identify how much of "B1" you want to check for.
CodeDim vCharacter Tit = Range("B1").Value vCharacter = Range("A1").Value Tit = Left(Tit, vCharacter)
'vCharacter = 12' will display your example.
However, if you are trying to use a single cell, to search multiple strings using a special character like "/" to split them, that it going to be tough since there are so many possibilities. You would have an easier time of making seperate cells, or a range, and searching for these using Carim's code with a slight adjustment to check for multiple Tits.
-
From Alan's example you would need to add the intersect range to specify where the action should occur.
Code
Display MoreOption Explicit Dim CutValue Dim CutCell As Range Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'You may want to be able to turn this functionality on/off '(either through text in a cell or via a button like a checkbox) 'If Sheets("Sheet1").Range("A1") = "ClickCopy" Then If Not IsEmpty(Target) _ And Not Intersect(Target, Range("A5:C10")) Is Nothing Then Cancel = True Target.Cut CutValue = Target.Text Set CutCell = Target End If 'End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'If Sheets("Sheet1").Range("A1") = "ClickCopy" Then If Not IsEmpty(CutValue) Then Target.FormulaR1C1 = CutValue CutValue = Empty CutCell.ClearContents Application.CutCopyMode = False End If 'End If End Sub
-
Re: Data validation - Generate single column array with values that contain comma?
That's a cool option to include the second name. Unfortunately this displays the LastName FirstName but does not include the comma seperator.
EG:
'
Smith Mark
Jacobs David
James Lebron -
I started converting my data validation, dynamically pulled from SQL, from lists to arrays. This works very well unless the SQL data returned contains a comma. When I use the following code it populates the data validation with only the LastName. My workaround has been to list the names as "FirstName LastName" but is there some code that will allow populating an array with "LastName, FirstName" EG: with a list of values that contain a comma?
Code
Display MorePrivate Sub DataValidation_Manager() Dim cnn As New ADODB.Connection _ , rst As New ADODB.Recordset _ , strSQL As String _ , LastRow As Long _ , StartRow As Long _ , vArray() As Variant _ , vServer as String _ , vDB as String _ , vUser as String _ , vPas as String vServer = "" vDB = "" vUser = "" vPas = "" LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(Excel.xlUp).Row strSQL = "SELECT Q.Name FROM(SELECT '''' AS 'NAME' " & _ " UNION ALL SELECT LastName+', '+FirstName AS 'NAME' " & _ " FROM Table " Group By LastName+', '+FirstName) Q " & _ " Order By Q.Name " cnn.Open "Provider=SQLOLEDB;Server=" & vServer & ";Database=" & vDB & ";User ID=" & vUser & ";Password=" & vPas & ";" rst.Open strSQL, cnn, adOpenForwardOnly, adLockReadOnly If Not rst.EOF Then vArray = Application.Transpose(Application.Transpose(rst.GetRows)) For StartRow = 4 To LastRow + 10 With Sheets("Sheet1").Range("A" & StartRow & "") With .Validation .Delete .Add Type:=xlValidateList, _ AlertStyle:=xlValidAlertStop, _ Formula1:=Join(vArray, ",") .ShowError = True .IgnoreBlank = True .ErrorTitle = "Select a Person !" .ErrorMessage = "You must select a 'Person' from the drop-down list. " End With End With Next End If rst.Close cnn.Close
-
-
Re: Create a report using vba
Based on what was on your report page I have put this together.
NOTE: You will need to remove everything below row 44, includeing the text and pivot chart, or it will run into a problem.
Code
Display MorePrivate Sub Compile_Report() Dim LastColumn As Integer _ , StartColumn As Integer _ , CheckColumn As Integer _ , CopyRow As Long _ , Copy_Column As Integer _ , Location As String _ , LocationCheck As String _ , Class As String _ , ClassCheck As String _ , SortRow As Long _ , StartRow As Long _ , LastRow As Long _ , Column_Total As Integer _ , Row_Total As Integer LastRow = Sheets("Report").Cells(Rows.Count, "A").End(Excel.xlUp).Row LastColumn = Sheets("Report").UsedRange.Columns.Count If LastRow > 44 Then Sheets("Report").Range("A45:G" & LastRow & "").ClearContents End If StartRow = 46 'Createrows for chart For StartColumn = 2 To LastColumn Class = Sheets("Report").Range(Cells(18, StartColumn), Cells(18, StartColumn)) Sheets("Report").Range("A" & StartRow & "") = Class StartRow = StartRow + 1 Next LastRow = Sheets("Report").Cells(Rows.Count, "A").End(Excel.xlUp).Row If LastRow > 45 Then Sheets("Report").Range("A46:A" & LastRow & "").Sort Key1:=Sheets("Report").Range("A46") Sheets("Report").Sort.SortFields.Clear End If 'Remove duplicates For StartRow = 46 To LastRow If Sheets("Report").Range("A" & StartRow & "") <> "" Then If Sheets("Report").Range("A" & StartRow & "") = Sheets("Report").Range("A" & StartRow + 1 & "") Then Sheets("Report").Range("A" & StartRow + 1 & "").EntireRow.Delete StartRow = StartRow - 1 End If End If Next LastRow = Sheets("Report").Cells(Rows.Count, "A").End(Excel.xlUp).Row StartRow = LastRow + 1 Sheets("Report").Range("A" & StartRow & "") = "Gran Total" LastRow = Sheets("Report").Cells(Rows.Count, "A").End(Excel.xlUp).Row SortRow = LastRow + 2 StartRow = SortRow 'Create Columns for chart For StartColumn = 2 To LastColumn Location = Sheets("Report").Range(Cells(15, StartColumn), Cells(15, StartColumn)) Sheets("Report").Range("A" & StartRow & "") = Location StartRow = StartRow + 1 Next LastRow = Sheets("Report").Cells(Rows.Count, "A").End(Excel.xlUp).Row Sheets("Report").Range("A" & SortRow & ":A" & LastRow & "").Sort Key1:=Sheets("Report").Range("A46") Sheets("Report").Sort.SortFields.Clear 'Remove duplicates For StartRow = SortRow To LastRow If Sheets("Report").Range("A" & StartRow & "") <> "" Then If Sheets("Report").Range("A" & StartRow & "") = Sheets("Report").Range("A" & StartRow + 1 & "") Then Sheets("Report").Range("A" & StartRow + 1 & "").EntireRow.Delete StartRow = StartRow - 1 End If End If Next LastRow = Sheets("Report").Cells(Rows.Count, "A").End(Excel.xlUp).Row 'Create Columns StartColumn = 2 For StartRow = SortRow To LastRow If Sheets("Report").Range("A" & StartRow & "") <> "" Then Sheets("Report").Range(Cells(45, StartColumn), Cells(45, StartColumn)) = Sheets("Report").Range("A" & StartRow & "") Sheets("Report").Range("A" & StartRow & "").ClearContents StartColumn = StartColumn + 1 End If Next Sheets("Report").Range(Cells(45, StartColumn), Cells(45, StartColumn)) = "Grand Total" 'Copy data to chart For StartColumn = 2 To LastColumn Class = Sheets("Report").Range(Cells(18, StartColumn), Cells(18, StartColumn)) Location = Sheets("Report").Range(Cells(15, StartColumn), Cells(15, StartColumn)) For Copy_Column = 2 To 7 LocationCheck = Sheets("Report").Cells(45, Copy_Column) For CopyRow = 46 To 55 ClassCheck = Sheets("Report").Cells(CopyRow, 1) If Class = ClassCheck And Location = LocationCheck Then Sheets("Report").Range(Cells(CopyRow, Copy_Column), Cells(CopyRow, Copy_Column)) = Sheets("Report").Cells(CopyRow, Copy_Column) + 1 End If Next Next Next 'TotalRowData For CopyRow = 46 To 55 For StartColumn = 2 To 6 Column_Total = Column_Total + Sheets("Report").Range(Cells(CopyRow, StartColumn), Cells(CopyRow, StartColumn)) Next Sheets("Report").Range(Cells(CopyRow, StartColumn), Cells(CopyRow, StartColumn)) = Column_Total Column_Total = 0 Next 'TotalColumnData For StartColumn = 2 To 7 For CopyRow = 46 To 55 Row_Total = Row_Total + Sheets("Report").Range(Cells(CopyRow, StartColumn), Cells(CopyRow, StartColumn)) Next Sheets("Report").Range(Cells(CopyRow, StartColumn), Cells(CopyRow, StartColumn)) = Row_Total Row_Total = 0 Next End Sub
-
Re: Pop up message and go to link
Try this.
Code
Display MoreOption Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim LastRow As Long Dim vRow As Long vRow = Target.Row LastRow = Sheets("sheet2").Cells(Rows.Count, "C").End(Excel.xlUp).Row If LastRow > 19 Then If Not Intersect(Target, Sheets("sheet2").Range("C20:C" & LastRow & "")) Is Nothing Then Application.EnableEvents = False Test_Action vRow Application.EnableEvents = True ElseIf Not Intersect(Target, Sheets("sheet2").Range("F20:F" & LastRow & "")) Is Nothing Then Application.EnableEvents = False Test_Action vRow Application.EnableEvents = True Else Exit Sub End If End If End Sub Function Test_Action(ByVal vRow As Long) Dim MSG1 As String _ , xTotal As Double _ , xUrl As String xUrl = "https://www.google.ae/" xTotal = Sheets("sheet2").Range("L" & vRow & "") On Error Resume Next If Format(xTotal) > 14.22 And (Sheets("sheet2").Range("C" & vRow & "") <> "" Or Sheets("sheet2").Range("F" & vRow & "") <> "") Then 'Response = MsgBox(prompt:="Select 'Yes' or 'No'.", Buttons:=vbYesNo) MSG1 = MsgBox("Filter DP is High, Do u want Raise Work Request " _ & vbNewLine & vbNewLine & "Row " & vRow & "'s value is '" & xTotal & "'." _ & vbNewLine & vbNewLine & "Select 'Yes' to Goto Maximo site or 'No' to Continue ?", vbCritical + vbYesNo) If MSG1 = vbYes Then Sheets("sheet2").Range("L" & vRow & "").Select Application.EnableEvents = True ActiveWorkbook.FollowHyperlink _ Address:=xUrl, NewWindow:=True End End If End If End Function
-
Re: Create a report using vba
You want a report that looks like a pivot table but is not a pivot table? Why not just run the macro recorder, select the data you want, then create a new pivot table from the data you want? Then just view the macro for the code you need to reproduce this for other data.
However, if you still do not want to use a pivot table when you will need to simply run a For Next loop, checking each column and copying the information where you want it. There are a number of posts what give examples on this.
-
Re: Pop up message and go to link
I am not able to reproduce this with your example workbook using the provided code. Can you attach the updated workbook, as an xlsm file, so I can see where you have placed the code?
-
Re: Pop up message and go to link
Modify as needed.
Code
Display MoreOption Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim LastRow As Long LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(Excel.xlUp).Row If LastRow > 1 Then If Not Intersect(Target, Sheets("Sheet1").Range("A2:B" & LastRow & "")) Is Nothing Then Application.EnableEvents = False Test_Action Application.EnableEvents = True Else Exit Sub End If End If End Sub Sub Test_Action() Dim MSG1 As String _ , StartRow As Long _ , xTotal As Double _ , LastRow As Long _ , xUrl As String LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(Excel.xlUp).Row xUrl = "https://www.google.ae/" If LastRow > 1 Then For StartRow = 2 To LastRow xTotal = Sheets("Sheet1").Range("C" & StartRow & "") If xTotal > 50 Then 'Response = MsgBox(prompt:="Select 'Yes' or 'No'.", Buttons:=vbYesNo) MSG1 = MsgBox("Error! " _ & vbNewLine & vbNewLine & "Row " & StartRow & "'s value is '" & xTotal & "'." _ & vbNewLine & vbNewLine & "Select 'Yes' to STOP or 'No' to CONTINUE.", vbYesNo) If MSG1 = vbYes Then Sheets("Sheet1").Range("C" & StartRow & "").Select Application.EnableEvents = True ActiveWorkbook.FollowHyperlink _ Address:=xUrl, NewWindow:=True End End If End If Next End If End Sub
-
Re: Continue to run Macro code after userform is hide
Add the following to launch your form:
If UserForm1.Visible = True Then
Unload UserForm1
End If -
Re: VBA Date fix
Maybe something like this?
Code
Display MoreDim myString As String, lung As Integer, i As Integer, pos As Integer, StartRow as Long, LastRow as Long LastRow = Sheets("**sheetname**").Cells(Rows.Count, "B").End(Excel.xlUp).Row myString = Range("B" & StartRow & "").Value lung = Len(myString) IF LastRow > 2 Then For StartRow = 3 to LastRow For i = 1 To lung pos = InStr(i, myString, " ") If pos <> 0 Then Exit For End If Next i Range("B" & StartRow & "").Value = Mid(myString, 1, pos) Next END IF
-
Re: On Double Cell Click Find Same Date On Another Sheet & Column
My bet is that dates are indeed serial but Excel is using a formula, to display the appropriate view, based on the number formatting used. We only see the view and not the formula being used.
-
Re: VBA Coding to send a common email to different email addresses based on cell valu
I made some adjustments to get this to work. The major problem was that in the middle of sending an email, from one workbook, the code was creating/updating a 2nd workbook. I suggest using your own email to test this as I accidentally sent an email to craig.pointon thinking this was a "fake" email.
Also, make sure to bind your button to the appropriate Sub
Code
Display MoreOption Explicit Sub Mail_ActiveSheet() 'Resource Request Form Oil & Gas 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 OutApp As Object Dim OutMail As Object Dim vName As String Dim Sndrange As Range Dim vFile As String Dim vTo As String Dim MSG As String With Application .ScreenUpdating = False .EnableEvents = False End With 'Add additional emails for each potential selection. If Sheets("Resource Request (Planner)").Range("B3") = "Oil & Gas" Then vTo = "[email protected]" ElseIf Range("B3") = "Offshore Support Vessel" Then vTo = "[email protected];[email protected]" ElseIf Sheets("Resource Request (Planner)").Range("B3") = "Select" Or Sheets("Resource Request (Planner)").Range("B3") = "" Then Sheets("Resource Request (Planner)").Range("B3").Select MSG = "Error !" _ & vbNewLine & vbNewLine & "The 'Sector', in cell 'B3', must be selected before an email will be sent." MsgBox MSG, , "Error" End End If Set Sourcewb = ActiveWorkbook vName = ActiveWorkbook.Name 'Copy the ActiveSheet to a new workbook ActiveSheet.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-2016 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 With ' 'Change all cells in the worksheet to values if you want ' With Destwb.Sheets(1).UsedRange ' .Cells.Copy ' .Cells.PasteSpecial xlPasteValues ' .Cells(1).Select ' End With ' Application.CutCopyMode = False 'Save the new workbook/Mail it/Delete it TempFilePath = Environ$("temp") & "\" TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss") vFile = TempFilePath & TempFileName & FileExtStr With Destwb .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum .Close End With Workbooks("" & vName & "").Activate Sheets("Resource Request (Planner)").Select With ThisWorkbook .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "EmailSheet" End With Sheets("EmailSheet").Range("B1:B5").Value = Sheets("Resource Request (Planner)").Range("B1:B5").Value Sheets("EmailSheet").Range("D1:D5").Value = Sheets("Resource Request (Planner)").Range("D1:D5").Value Sheets("EmailSheet").Select Sheets("EmailSheet").Range("B1:B5,D1:D5").Select Set Sndrange = Selection With Sndrange ActiveWorkbook.EnvelopeVisible = True With .Parent.MailEnvelope With .Item .To = vTo .CC = "" .BCC = "" .Subject = "Test this is the Subject line" 'When sending email via excel the body is the sheet '.Body = "Test Hi there" .Attachments.Add vFile 'You can add other files also like this '.Attachments.Add ("C:\test.txt") .Send 'or use .Display End With End With End With 'Delete the file you have send Kill TempFilePath & TempFileName & FileExtStr Sheets("Resource Request (Planner)").Select Application.DisplayAlerts = False Sheets("EmailSheet").Delete Application.DisplayAlerts = True With Application .ScreenUpdating = True .EnableEvents = True End With Sheets("Resource Request (Planner)").Range("B3").Select End Sub
-
Re: VBA Code Keeps Changing Bar Graphs To Line Graphs
I would set the ChartType value for each chart in the series.
Here is something that I use to be able to easily change chart type.
Code
Display MoreDim ole As ChartObject Dim i As Integer Dim vChartType As Integer Dim MyCharts(1 To 18) As String MyCharts(1) = "Q1 Chart" MyCharts(2) = "Q1 NA Type" MyCharts(3) = "Q2 Chart" MyCharts(4) = "Q2 NA Type" MyCharts(5) = "Q3 Chart" MyCharts(6) = "Q3 NA Type" MyCharts(7) = "Q4 Chart" MyCharts(8) = "Q4 NA Type" MyCharts(9) = "Fiscal Chart" MyCharts(10) = "Fiscal NA Type" MyCharts(11) = "All Time Chart" MyCharts(12) = "All Time NA Type" MyCharts(13) = "Defined Chart" MyCharts(14) = "Defined NA Type" MyCharts(15) = "Classes Completed" MyCharts(16) = "Completed Types" MyCharts(17) = "Location" MyCharts(18) = "Online" For i = 1 To 18 If i < 9 Then 'Pie Chart vChartType = 5 ElseIf i > 8 AND i < 13 Then 'Bar Chart vChartType = 51 ELSEIF i > 12 Then 'Line Chart vChartType = 4 END IF Set ole = ChartObjects(MyCharts(i)) If ole.Visible = False Then ole.Visible = True ole.Activate ActiveChart.ChartType = vChartType ole.Visible = False Else ole.Activate ActiveChart.ChartType = vChartType End If Next
-
Re: VBA Coding to send a common email to different email addresses based on cell valu
I took a quick look. I would recommend adding a variable, based on the selection, for the email address to be used.
Code
Display MoreDIM vTo as String If Sheets("Resource Request (Planner)").Range("B3") = "Oil & Gas" Then vTo = "[email protected]" ElseIf Range("B3") = "Offshore Support Vessel" Then vTo = "[email protected];[email protected]" End IF
For the info to include in the email body you will need to select the data you want. And then wrap this in your email.
Code
Display MoreDIM Sendrng As String Set Sendrng = Selection Sheets("Resource Request (Planner)").Range("B1:B5,D1:D5").Select With Sendrng With OutMail .to = vTo .CC = "" .BCC = "" .Subject = "Test this is the Subject line" .Body = "Test Hi there" .Attachments.Add Destwb.FullName 'You can add other files also like this '.Attachments.Add ("C:\test.txt") .Send 'or use .Display End With End With
-
Re: Copy checkboxes and data from one sheet to another
1) On your VBA window go to Tools/References and check Microsoft ActiveX Data Objects 2.7 library. Save, close, and reopen your workbook.
2) All of your checkboxes, in the attached file, are form checkboxes. They need to be ActiveX checkboxes. This will allow you to trigger specific code when the checkbox is checked/unchecked. Form checkboxes are just graphical items (if there is a way to generate VBA code via these form controls it is not something I am familiar with). To insert an ActiveX checkbox go to the Developer tab and select the Insert button. Select the checkbox from the ActiveX section (bottom).
3) When you insert the checkboxes make sure to name them so its easy to identify them. EG: If you have a problem with Checkbox10528 it can be difficult to identify vs Dial Soap_Orange. Once you have the checkboxes created double click one and it will open the action, for that checkbox, in the VBA window. Copy CheckBox_Action into this to trigger the script. You will need to update the code with each of the checkbox names so it can run through the list.
-
Re: Copy checkboxes and data from one sheet to another
Here is a quick example that should get your started. Please note that all of the checkboxes will need to be ActiveX checkboxes and not form checkboxes. This code is set to check every checkbox when a action is taken on any checkboxes. This can be helpful if you want to quickly update all the text but not have to uncheck/check every checkbox.
Code
Display MorePrivate Sub Checkbox_Action() 'change final number to total number of checkboxes Dim MyCheckboxes(1 To 5) As String Dim ole As Object Dim iRow As Long MyCheckboxes(1) = "Check_1" 'MyCheckboxes(2) = "Check_2" 'MyCheckboxes(3) = "Check_3" 'MyCheckboxes(4) = "Check_4" 'MyCheckboxes(5) = "Check_5" 'change final number to total number of checkboxes For i = 1 To 1 'row of data that corresponds to text to copy iRow = i + 1 Set ole = Sheets("Sheet1").OLEObjects(MyCheckboxes(i)) 'Check if value is checked If ole.Object.Value = True And Sheets("Sheet1").Range("B" & iRow & "") <> "" Then 'Change look of checkbox ole.Object.BackColor = Sheets("Sheet1").Range("A" & iRow & "").Interior.Color ole.Shadow = True 'copy data to specific cell Sheets("Sheet2").Range("B" & iRow & "") = Sheets("Sheet1").Range("B" & iRow & "") ElseIf ole.Object.Value = False Then 'Change to different color ole.Object.BackColor = Sheets("Sheet1").Range("A" & iRow & "").Interior.Color ole.Shadow = False 'clear data from specific cell Sheets("Sheet2").Range("B" & iRow & "") = "" End If Next i End Sub Private Sub Check_1_Click() Checkbox_Action End Sub