Hi Grace,
I have updated the original StackExchange thread with the final code and a link to here. If you could please head there and mark it as solved. Also if you can click on like fo the solution here and check the resolved checkbox (don't worry if you cannot find it) on this page.
Hi Victor,
The code below currently returns to the text box and highlights the text so you can either start typing to overtype the existing search or make a new selection using the same search. If you want to delete the text in the text box delete the .selstart and .sellength lines and remove the comment symbol to so the .value line works instead.
I also put the option of a beep sounding rather than the msgbox appearing, again delete the beep line if that is not what you want.
Then there is the option for a second textbox hidden below the listbox, if you expand the size of the form in developer and put a second textbox in there then shrink the form so it is hidden again the code will change the height (see attachment).
Private Sub ListBox1_Click()
Dim x As Long
If Range("G9").Value2 = vbNullString Then GoTo PasteMe
Dim wsX As Worksheet: Set wsX = Worksheets(Range("G9").Value2)
ActiveCell.Value2 = UserForm1.ListBox1.Value
On Error Resume Next
x = Application.Match(ActiveCell.Offset(0, -1).Value, wsX.Range("B6:B500"), 0)
If Err.Number <> 0 Then
'MsgBox "The street you selected doesn't have this item"
Beep
Me.Height = 240
Me.TextBox2.Value = "INVALID SELECTION, PLEASE SELECT ANOTHER"
With Me.TextBox1
.SetFocus
.SelStart = 0
.SelLength = Len(.Text)
'.Value = vbNullString
End With
Err.Clear
Else
PasteMe:
ActiveCell.Value2 = UserForm1.ListBox1.Value
Unload Me
End If
End SubWe probably need to move from this thread, it is getting far from the original question. If you have a share drive for the file you could send me a link to the drive. Use the messaging rather than this thread.
Great to hear it is working, if you want me to change the output in some way let me know.
Hi Victor, I had a look in context and understand how it works now, nice job!
The alternative is to catch the error prior to exiting the form so the user has the chance to correct the selection without having to double click again, eg:
Private Sub ListBox1_Click()
Dim x As Long
If Range("G9").Value2 = vbNullString Then GoTo PasteMe
Dim wsX As Worksheet: Set wsX = Worksheets(Range("G9").Value2)
ActiveCell.Value2 = UserForm1.ListBox1.Value
On Error Resume Next
x = Application.Match(ActiveCell.Offset(0, -1).Value, wsX.Range("B6:B500"), 0)
If Err.Number <> 0 Then
MsgBox "The street you selected doesn't have this item"
Err.Clear
Else
PasteMe:
ActiveCell.Value2 = UserForm1.ListBox1.Value
Unload Me
End If
End SubHi Victor,
I am not sure what you are trying to do in your code for the doubleclick, there is no waythe mergearea should activate. It will only enter the if statement if you doubleclick on the range and then it will show the form, there is no reason for an error to occur so the error number will never not be 0 (unless there is something I am missing).
If you want to discuss what you are trying to get to happen here PM me, if it is working as you expect all good.
Justin
Hi Victor,
I changed the listbox code to allow for a blank and to test if G9 is a date value, I have not tested thoroughly so let me know if it errors. If you intend to use the forms across more sheets I will recommend a differnt approach to the code using Case.
Hi Victor,
I added a TRUE FALSE check for the reset, so now if you press reset you do not activate the worksheet_change event for the H column.
I chaned the code for the form so that when you select an item the resulting value in the B column is checked against the selected worksheet and if it does not exist you get a message pop-up.
Is that what you were after?
Hi Victor,
I think this is all you need, otherwise I will need to clarify with you.
Sub XShts(TgtRW As Long)
GoTo MyStart
MyErr:
MsgBox "Error: Worksheet listed in G9 may not exist"
GoTo MyEnd
MyStart:
On Error GoTo MyErr
Dim ws3 As Worksheet: Set ws3 = Sheet3
If Len(ws3.Range("G9")) Then
Dim wsX As Worksheet: Set wsX = Worksheets(Range("G9").Value2)
Dim MyXRW As Long
On Error GoTo MyEnd
MyXRW = Application.Match(Range("B" & TgtRW), wsX.Range("B6:B500"), 0) + 5
If IsNumeric(MyXRW) Then wsX.Range("F" & MyXRW) = wsX.Range("F" & MyXRW) + CStr(ws3.Range("H" & TgtRW))
End If
MyEnd:
End SubThis now catches the error if there is an error with the worksheet name, but ignores it and ends the sub if the error is due to a match fail.
Hi,
This is not as complex as the example in your video, it might do what you are after.
Click on B2 to activate the form, there is also a beforedoubleclick or a beforerightclick option in the code for the sheet if you want to try them. Just drag the pice of code from its current position into the others to try them.
In the form type in the textbox to change the fill for the listbox.
Unfortunately I think you are going to require a macro solution probably with forms, I have seen this question a lot and I am not aware of a solution other than that presented here. Maybe one of the mods knows a solution for it but I think that is where it will wind up.
Hi,
I have used the technique outlined here:
I used a different method to make a volatile range than is described in the video, I also tested by expanding the list of products to over 6000 and the response is instant.
The only issue that I know of which might be a problem is that it depends on how recent your version of excel is as to whether the functions are available.
Let me know how it goes:
Hi,
If you load an example workbook, with examples of data type and sheet layout, and expected result, it would be an easier solve.
Why do you not want to use a form? you can have the form return to the page after selection for example.
I had made a mistake in the above, and I could not get the code to work correctly in the workbook you uploaded for some reason - I think it was the filter you had used.
If you open this book and press the button on sheet 2 it should give the results I outlined on the other forum.
If it is working correctly we can work on cleaning up the output formatting to meet needs, as it is the code is not very flexible. If it fails to run entirely it meansyou need to switch on the reference for solver in the visual basic developer window. ALT-F11 should open it and then TOOLS, then REFERENCES and look for SOLVER and make sure it is checked.
NB: The code in this workbook has a minor change to the previous post on line 68.
Hi Grace,
You need to ensure you follow the rules here, so let them know you have the thread on the other forum:
https://superuser.com/question…=1#comment2546142_1656880
I will have another look at the code tomorrow, I ran it but it is not working on your sheet as it did on the example I put together from the pictures you posted. Not sure why.
Anyone else interested, this is the code that was working to automate solver:
Sub SolverMacro(Add1 As String, Jval As Long)
Dim ws1 As Worksheet: Set ws1 = Sheet1
Dim ws2 As Worksheet: Set ws2 = Sheet2
Dim MyStr As String, MyCol As Long
Dim c As Range
mycount = 1
Do While ws2.Range("H4") > 1 And mycount < 5
'Solver section
'--------------------
SolverReset
SolverOk SetCell:="$H$3", MaxMinVal:=3, ValueOf:=0, ByChange:=Add1, _
Engine:=2, EngineDesc:="Simplex LP"
SolverAdd CellRef:=Add1, Relation:=5, FormulaText:="binary"
SolverAdd CellRef:="$H$4", Relation:=3, FormulaText:="1"
SolverSolve userfinish:=True
SolverFinish KeepFinal:=1 ', ReportArray:=Array(1)
'--------------------
'Loop identifies all invoices found in this solve and copies to a string then deletes the row
MyStr = "Total to 0: "
For i = Range(Add1).Cells.Count + 1 To 2 Step -1
If ws2.Range("D" & i) = 0 Then
ws2.Range("D" & i) = 1
GoTo MyNxti
Else
MyStr = Trim(MyStr & " " & ws2.Range("B" & i) & ", ")
ws2.Range("A" & i).Resize(1, 5).Delete xlUp
End If
MyNxti:
Next i
' ---------------------------
MyCol = ws2.Cells(Jval, Columns.Count).End(xlToLeft).Column + 1 'identifies last used row.
If Trim(MyStr) = "Total to 0:" Then GoTo MyExitLoop
ws2.Cells(Jval, MyCol) = Trim(MyStr) 'pastes string containing invoices that have added to zero
Add1 = "D2:D" & ws2.Range("D2").CurrentRegion.Rows.Count + 1
mycount = mycount + 1
Loop
MyExitLoop:
Add1 = "D2:D" & ws2.Range("D2").CurrentRegion.Rows.Count + 1
MyStr = "Outstanding: "
For Each c In ws2.Range(Add1)
MyStr = MyStr & ws2.Range("B" & c.Row) & ", "
ws2.Range("A" & c.Row).Resize(1, 5).Clear
Next c
MyCol = ws2.Cells(Jval, Columns.Count).End(xlToLeft).Column + 1 'identifies last used row.
ws2.Cells(Jval, MyCol) = MyStr 'pastes string containing invoices that have not added to zero
MyStr = vbNullString
End Sub
Sub ExtractorSub()
mystart = Time
Application.ScreenUpdating = False
'Declare variables
'---------------------------------------
Dim ws1 As Worksheet: Set ws1 = Sheet1
Dim ws2 As Worksheet: Set ws2 = Sheet2
Dim MyUniqueArr, MyFullArr
Dim x As Long, y As Long, MyRW As Long, Add1 As String, Add2 As String
ws2.Range("G1") = "Target"
ws2.Range("H1") = 0
ws2.Range("G2") = "Sum"
ws2.Range("H2") = "=SUM(INDIRECT(""$E2:E""&COUNTA($E:$E)+1))"
ws2.Range("G3") = "Difference"
ws2.Range("H3") = "=SUM(INDIRECT(""$E2:E""&COUNTA($E:$E)+1))"
ws2.Range("G4") = "Sum of Bin"
ws2.Range("H4") = "=SUM(INDIRECT(""$D2:D""&COUNTA($D:$D)+1))"
'------------------------------------------
'use autofilter to create unique list on sheet 2
ws1.Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws2.Range("J1"), Unique:=True
'create array of full list and unique
MyUniqueArr = Application.Transpose(ws2.Range("J2:J" & ws2.Range("J" & Rows.Count).End(xlUp).Row))
MyFullArr = Application.Transpose(ws1.Range("A1:A" & ws1.Cells(Rows.Count, 1).End(xlUp).Row))
' place header on unique list
ws2.Range("Extract") = "ID Number"
'Loop through all unique ID numbers
For x = LBound(MyUniqueArr) To UBound(MyUniqueArr)
For y = LBound(MyFullArr) To UBound(MyFullArr)
If MyUniqueArr(x) = MyFullArr(y) Then
MyRW = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
ws1.Range("A" & y).Resize(1, 3).Copy ws2.Range("A" & MyRW).Resize(1, 3)
ws2.Cells(MyRW, 4) = 1
ws2.Cells(MyRW, 5) = "=$C" & MyRW & "*" & "$D" & MyRW
End If
Next y
Add1 = "D2:D" & MyRW
Call SolverMacro(Add1, x + 1)
Next x
Application.ScreenUpdating = True
MsgBox "Code took: " & Time - mystart & " seconds to complete."
End SubAs indicated in the post on the other forum, I have activated the solver addin and ticked the solver reference (this does not work otherwise).
Hi,
Try this code and let me know if it does some of what you are after, if not then I need a better idea of what you are trying to achieve.
Sub autofilterMe2()
Dim c1 As Range, c2 As Range
Dim i As Long, x As Long, p As Long
Dim temp As String
Dim myarr()
ReDim myarr(Selection.Rows.Count)
i = 0
For Each c1 In Selection
temp = vbNullString
For Each c2 In Selection
For x = Len(c1) To 1 Step -1
If c2.Address = c1.Address Then GoTo NxtC2
If Left(c1, x) = Left(c2, x) Then
If Len(Left(c2, x)) > temp Then temp = Left(c2, x)
End If
GoTo NxtC2
Next x
NxtC2:
Next c2
If temp = vbNullString Then GoTo NxtC1
myarr(i) = temp
i = i + 1
NxtC1:
Next c1
ReDim Preserve myarr(i - 1)
For i = LBound(myarr) To UBound(myarr)
Selection(1).Offset(i, 1) = myarr(i)
Next i
End SubOn your sheet1 select A2:A49 and run the code.
Hi DA,
There is a minor error in the code as it is starting its comparison for the OUTPUT at A3 but writing to A2, so if you run it twice it rewrites the first line. To correct it, in the data as formatted in your example sheet, you need to change the serials3 to cover from A2:A ...
Hi,
The code is for a worksheet_change event so does not need to be linked to a button.
I may have misinterpretted what you wanted, this works so that as you type the serial number in LIST it updates the OUTPUT but only for that line/row. If you want a macro for a button I will have a look at that soon.
Thank you for having a look, based on the two results I think it may be related to a windows update, I saw reference to this during some of my searches. I will just have to try a different approach I guess.
Hi Daghs,
Try this code on the "List" worksheet.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)) Is Nothing Then
Dim x As Long, y As Long, MyRw As Long
Dim ws2 As Worksheet, ws3 As Worksheet
Set ws2 = Sheet2
Set ws3 = Sheet3
On Error Resume Next
x = Application.Match(Target.Value, ws2.Range("A3:A" & ws2.Range("A" & Rows.Count).End(xlUp).Row), 0)
If Err.Number <> 0 Then
Err.Clear
y = Application.Match(Target.Value, ws3.Range("A3:A" & ws3.Range("A" & Rows.Count).End(xlUp).Row), 0)
If Err.Number = 0 Then GoTo MyEnd
MyRw = ws3.Range("A" & Rows.Count).End(xlUp).Row + 1
Target.Resize(1, 2).Copy ws3.Range("A" & MyRw).Resize(1, 2)
ws3.Cells(MyRw, 3).Value2 = "No Record Found"
GoTo MyEnd
End If
y = Application.Match(Target.Value, ws3.Range("A3:A" & ws3.Range("A" & Rows.Count).End(xlUp).Row), 0)
If Err.Number = 0 Then GoTo MyEnd
MyRw = ws3.Range("A" & Rows.Count).End(xlUp).Row + 1
ws2.Range("A" & x + 2).Resize(1, 8).Copy ws3.Range("A" & MyRw).Resize(1, 8)
MyEnd:
Err.Clear
End If
End Sub