Updated and Edited
I am new to this whole world, but here is my issue as it stands:
As the userform initializes the below code applies a filter to my 'clean import', copies column a into a temp sheet, which is what the listbox uses to populate itself.
Set ws = ThisWorkbook.Worksheets("Clean_Import")
ws.Activate
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
ws.Range("A1:K1000").AutoFilter Field:=5, Criteria1:="<1"
Range("A:A").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("TempSheet").Select
Columns("A:A").Select
Range("A2").Activate
ActiveSheet.Paste
ODList1.List = Sheets("TempSheet").Range("A2:A100").Value
End Sub
From then in it is just double clicking on the list box to lookup the selected items and vlook some data into text boxes.
With Me.ODList1
For i = 0 To .ListCount - 1
If .Selected(i) Then
TextBox11.Value = Application.VLookup(.List(i, 0), Sheet3.Range("A1:K100"), 3)
TextBox12.Value = Format(Application.VLookup(.List(i, 0), Sheet3.Range("A1:K100"), 7), "dd / mm / yyyy")
TextBox13.Value = Application.VLookup(.List(i, 0), Sheet3.Range("A1:K100"), 10)
Exit For
End If
Next
End With
This code works in all but one of my scenarios. I realise now if i select the list box item that happens to be the first line in the range OR the last in the range in my 'clean import' then I get the following error.
Run-Time error '-2147352571 (80020005)': Could not set the value
property. Type mismatch.
The only thing I can think is that the value doesn't match, but that doesn't seem possible as the list box is populated from a direct copy from the range it is vlooking through
I look forward to hearing your thoughts,
Cheers,
Bill
That is happening because the Vlookup is not able to find a match. Here is a simple way to reproduce the error
Private Sub CommandButton1_Click()
TextBox1.Value = Application.VLookup("Sid", Sheet1.Range("A1:K100"), 3)
End Sub
To handle this, you need to introduce proper error handling. Here is an example
Dim Ret As Variant
Ret = Application.VLookup("Sid", Sheet1.Range("A1:K100"), 3)
If IsError(Ret) Then
TextBox1.Value = "Error"
Else
TextBox1.Value = Ret
End If
I made some small adjustments to the way I brought the data in and problem went away.
Not really sure where the issue was creeping in. But it crept back out again.
Related
I am trying to automate repetitive tasks by using .inputboxes in Excel.
Note: CopyAmt is an integer returned from another InputBox, userInputRange is type 8 box, and RowCnt is the Row.Count of userInputRange.
For i = 1 To CopyAmt
userInputRange.Copy
ActiveCell.Offset(RowCnt, 0).Activate
ActiveCell.PasteSpecial
ActiveSheet.Range(ActiveCell.Offset(, 24), ActiveCell.Offset(RowCnt - 1, 24)).Value = Application.InputBox(Prompt:="Internal Value", Type:=2)
Next i
If a user was to click Cancel, I would want to exit the sub only after deleting the selection that was just pasted on line 4 of the above code. This is what I was trying.
For i = 1 To CopyAmt
userInputRange.Copy
ActiveCell.Offset(RowCnt, 0).Activate
ActiveCell.PasteSpecial
ActiveSheet.Range(ActiveCell.Offset(, 24), ActiveCell.Offset(RowCnt - 1, 24)).Value = Application.InputBox(Prompt:="Internal Value", Type:=2)
If ActiveSheet.Range(ActiveCell.Offset(, 24), ActiveCell.Offset(RowCnt - 1, 24)).Value = False Then
Selection.Delete
Exit Sub
End If
Next i
This results in a mistype and I would love some clarification on the things I am doing wrong, or just not efficiently.
Thank you for your time.
Sean,
Give this a try. Note: this is untested code but should work.
For i = 1 To CopyAmt
userInputRange.Copy
ActiveCell.Offset(RowCnt, 0).Activate '*** Changes ActiveCell!
With ActiveCell '*** Use With block to simplify code
.PasteSpecial
Temp = Application.InputBox(Prompt:="Internal Value")
If (Temp <> False) Then
ActiveSheet.Range(.Offset(, 24), .Offset(RowCnt - 1, 24)).Value = Temp
Else
.ClearContents '*** You don't want to delete the cell just clear the value.
Return '*** Get me out of the Subroutine
End If
End With
Next i
Edited: Removed the Type=2 from the Application.InputBox line.
You can test for the type of data your need in the latter code.
I already have a barcode scanner VBA function, that recognizes the barcode number, but the problem I have is that I have to click enter every time, is there any way to do it automatically and store the count in a certain column? Currently it works if I enter the same value stored in column B, it will count the records in column C, but I want to avoid hitting enter every time
This is what I got so far
Private Sub btnAdd_Click()
Dim TargetCell As Range
If WorksheetFunction.CountIf(Sheets("Sheet1").Columns(2), TextBox1.Value) = 1 Then
Set TargetCell = Sheets("Sheet1").Columns(2).Find(TextBox1.Value, , xlValues, xlWhole).Offset(0, 1)
TargetCell.Value = TargetCell.Value + 1
Else
MsgBox "Code not found"
End If
Me.Hide
End Sub
It's hard to say what you have. For example, who presses the button? Or, does your scanner enter a return. I think the code below should work under any circumstances. Please try it.
Private Sub TextBox1_Change()
Dim TargetCell As Range
Dim Qty As Long
With TextBox1
If Len(.Value) = 3 Then
Set TargetCell = Worksheets("Sheet1").Columns(2) _
.Find(.Value, , xlValues, xlWhole)
If TargetCell Is Nothing Then
MsgBox """" & .Value & """ Code not found"
Else
With TargetCell.Offset(0, 1)
Qty = .Value + 1
.Value = Qty
End With
Application.EnableEvents = False
TextBox1.Value = "Count = " & Qty
Application.EnableEvents = True
End If
.SelStart = 0
.SelLength = Len(.Value)
End If
End With
End Sub
I think you have a user form and in this form you have a text box called TextBox1. If so, the code should be in the user form's code module. If you have a text box in your worksheet paste the code to the code module of the sheet on which the text box resides.
Now, you need to adjust this line of code If Len(.Value) = 3 Then to determine when to process the data. This is because the Change event will occur whenever even a single character is entered. I tested with 3 characters. Change the number to a value equal to the length of the numbers you scan in. In theory that still leaves the CR hanging which your scanner might also send. If that causes a problem experiment with >= in place of the = in my code.
The code will add the scan to the existing quantity, just as you had it, and indicate the new total in the text box, in case you are interested. You might replace this with "OK". The code will select the text it enters. Therefore when you enter something else, such as a new scan, it will be over-written without extra clicks being required.
I will admit to being a terrible at code, and have always struggled with Macros... forgive my ignorance.
What I am working on building is a part number index that will create a new sequential number within a numerical series after a macro-button is pressed.
I'd like each button to scan between a range [i.e. 11-0000 (MIN) and 11-9999 (MAX)] and select the max value cell that exists. At that selection point insert an entire new row below with the next + 1 sequential number in the "B" column.
I have my button creating the table row as I would like, however I need help in defining the ".select(=Max(B:B))" and as I understand Max will also limit the # of line items it queries?
I have also been playing with .Range("B" & Rows.CountLarge) with little to no success.
Ideally the 11-**** button [as seen in the screen cap] should insert a sequential number below the highlighted row.
Maybe I'm way over my head, but any guidance even in approach or fundamental structure of the code would help be greatly appreciated!
Private Sub CommandButton1_Click()
Sheets("ENGINEERING-PART NUMBERS").Range("B" & Rows.CountLarge).End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.EntireRow.Insert Shift:=xlDown
ActiveCell.Value = "=ActiveCell + 1"
End Sub
Screen Cap of Spread Sheet
Perhaps there is a simpler solution that I've overlooked, but the below will work.
Insert a module into your workbook and add this code:
Public Sub AddNextPartNumber(ByVal FirstCellInColumn As Range, Optional ByVal PartMask As Variant = "")
Dim Temp As Variant, x As Long, MaxValueFound(1 To 2) As Variant
'Some error checking
If PartMask = "" Then
MsgBox "No part mask supplied", vbCritical
Exit Sub
ElseIf Not PartMask Like "*[#]" Then
MsgBox "Invalid part mask supplied; must end in ""#"".", vbCritical
Exit Sub
ElseIf PartMask Like "*[#]*[!#]*[#]" Then
MsgBox "Invalid part mask supplied; ""#"" must be continuous only.", vbCritical
Exit Sub
End If
'Get the column of data into an array
With FirstCellInColumn.Parent
Temp = .Range(FirstCellInColumn, .Cells(.Rows.Count, FirstCellInColumn.Column).End(xlUp))
End With
'Search through the array and find the largest matching value
For x = 1 To UBound(Temp, 1)
If Temp(x, 1) Like PartMask Then
If MaxValueFound(1) < Temp(x, 1) Then
MaxValueFound(1) = Temp(x, 1)
MaxValueFound(2) = x
End If
End If
Next x
'Output new part number
If MaxValueFound(2) = 0 Then
'This part mask doesn't exist, enter one with 0's at the end of the list
With FirstCellInColumn.Offset(x - 1, 0)
.Value = Replace(PartMask, "#", 0)
.Select
End With
Else
'Get the length of the number to output
Dim NumberMask As String, NumFormatLength As Long
NumFormatLength = Len(PartMask) - Len(Replace(PartMask, "#", ""))
NumberMask = String(NumFormatLength, "#")
'Determine the new part number
MaxValueFound(1) = Replace(MaxValueFound(1), Replace(PartMask, NumberMask, ""), "")
MaxValueFound(1) = Replace(PartMask, NumberMask, "") & Format((MaxValueFound(1) * 1) + 1, String(NumFormatLength, "0"))
'Insert row, add new part number and select new cell
FirstCellInColumn.Offset(MaxValueFound(2), 0).EntireRow.Insert
With FirstCellInColumn.Offset(MaxValueFound(2), 0)
.Value = MaxValueFound(1)
.Select
End With
End If
End Sub
Then, for each button, you write the code like this:
Private Sub CommandButton1_Click()
'this is the code for the [ADD 11-****] button
AddNextPartNumber Me.Range("B16"), "11-####"
End Sub
Private Sub CommandButton2_Click()
'this is the code for the [ADD 22-****] button
AddNextPartNumber Me.Range("B16"), "22-####"
End Sub
This has been written assuming that inserting a new row onto your sheet won't affect other data and that adding new data to the bottom of the table without inserting a row also won't affect other data.
Assuming you're working with a table, by default it should auto-resize to include new data added to the last row.
Good luck learning the ropes. Hopefully my comments help you understand how what I wrote works.
I'm new to VBA and I'm trying to set up a customizable sheet that allows the user to filter certain columns based on the checkboxes that I have set up. So far, I understand how checkboxes work and how I can integrate them into the code, but I think I have an issue with the autofilter function. Specifically, I think that I'm putting the wrong value for Criteria1.
I've been looking around for similar coding problems, but none of them seem to work with what I'm trying to do.
TL;DR I think my issue lies with how I format the array to put in Criteria1 of the AutoFilter()
Sub Auto_filter()
'variables are for checkboxes'
Dim VC1500 As Shape
Dim VC7500 As Shape
Dim VC144024 As Shape
'initiates to check for the checkboxes'
Set VC1500 = Sheets("Sheet7").Shapes("Check Box 4")
Set VC7500 = Sheets("Sheet7").Shapes("Check Box 5")
Set VC144024 = Sheets("Sheet7").Shapes("Check Box 6")
'if statement that will add a string to strCriteria if checkbox is true'
If VC1500.OLEFormat.Object.Value = 1 Then
strCriteria = strCriteria & ", VC1500"
End If
If VC7500.OLEFormat.Object.Value = 1 Then
strCriteria = strCriteria & ", VC7500"
End If
If VC144024.OLEFormat.Object.Value = 1 Then
strCriteria = strCriteria & ", 144024"
End If
'with statement that finds for column vendor then filter it based on
strCriteria, I think this is where my issue is'
With Worksheets("Open Purchase Orders")
With .Range("A1", .Cells(1, Columns.Count).End(xlToLeft))
Set vendorfind = .Rows(1).Find("Vendor")
If Not vendorfind Is Nothing Then
.AutoFilter Field:=vendorfind.Column,
Criteria1:=Split(strCriteria, ", "), Operator:=xlFilterValues
End If
End With
.AutoFilterMode = False
End With
End Sub
I expect to have the sheet filtered based on the checkboxes.
I get a runtime error 9 error:subscript out of range
Have you tried using Slices?
Its easy and should do simple filters without Macros.
Select your data > Insert Table.
Once the table is done, from the Design tab you can select "Insert Slicer".
Try if this solves your problem.
Some parts of that code look to me like scratching your left ear with your right hand going over your head. But I'm not entirely clear on how it actually looks (a sample would be helpful) - does each vendor have some separate indication column? If so, what are you filtering there? A vendor tag, by the looks of it?
This for example is a solution for a single vendor column (D) which may contain the 3 names. It basically applies an autofilter of a list of values. (I'm using activex checkboxes below as their properties can be accessed directly.)
Private Sub VC1500_Click()
Update_Filter
End Sub
Private Sub VC7500_Click()
Update_Filter
End Sub
Private Sub VC144024_Click()
Update_Filter
End Sub
Private Sub Update_Filter()
Dim varr_filter(3) As String
Dim indshow As Boolean
indshow = True
If VC1500 Then
varr_filter(0) = VC1500.Caption
indshow = False
End If
If VC7500 Then
varr_filter(1) = VC7500.Caption
indshow = False
End If
If VC144024 Then
varr_filter(2) = VC144024.Caption
indshow = False
End If
If indshow Then
Range("$A:$D").AutoFilter
Else
Range("$A:$D").AutoFilter field:=4, Criteria1:=varr_filter, Operator:=xlFilterValues
End If
End Sub
Note: Pick the correct column for filtering as the "field" value, and if you wish to separate the checkboxes from the form for some reason, then add """sheets("sheetname").{each checkbox}""".
Alternatively, if each of the vcs possesses a separate column, and seeking rows which literally say "vendor", I'd merge them in the sheet like so:
E2=if(cond1)*checkbox1 + if(cond2)*checkbox2 + if(cond3)*checkbox3 ; E > 0.
Cond1 could be b2="Vendor", for example.
To make the sheet display all cols when no ticks are selected,
I've added another value: 1 - max(checkboxes).
E6=1-MAX($H$4:$H$6) + IF(AND(B2="Vendor"),1,0)*$H$4 +
IF(AND(C2="Vendor"),1,0)*$H$5 + IF(AND(D2="Vendor"),1,0)*$H$6
That's one example where a hidden sheet value helps, since you can actually define such a column without vb. And then, the code itself is simplified a bit.
Private Sub VC1500_Click()
If VC1500.Value Then
Range("$H$4").Value = 1
Else
Range("$H$4").Value = 0
End If
Update_Filter
End Sub
Private Sub VC7500_Click()
If VC7500.Value Then
Range("$H$5").Value = 1
Else
Range("$H$5").Value = 0
End If
Update_Filter
End Sub
Private Sub VC144024_Click()
If VC144024.Value Then
Range("$H$6").Value = 1
Else
Range("$H$6").Value = 0
End If
Update_Filter
End Sub
Private Sub Update_Filter()
Range("$A:$E").AutoFilter field:=5, Criteria1:=">0", Operator:=xlFilterValues
End Sub
It's also easier to transition to a form control, by checking the range value during click instead of the checkbox, and hiding column H. Not entirely bulletproof yet sufficient for the average user. Either that or read the shape as you wrote.
Edit: Added tested code above for both cases (single col, multicol), including displaying all rows when no tickboxes are checked rather than none. Here are the demo shots.
Single col code
Single col sample sheet
Single col filtered
Multicol code
Multicol sample
Multicol filtered
I want to create a VBA macro for Excel 2013 to move the cursor. I am simply re-mapping keyboard shortcuts, e.g. I want to move the cursor down using CTRL+J instead of the down arrow. So I don't need anything fancy, just a simple cursor move. I also want to do this in VBA, so I'm not looking for, e.g., an Excel plugin or add-in or anything like that.
If, under the "Developer" tab, I select "Use Relative References", and then simply record a macro moving the cursor down, I get the following, which does move the cursor:
ActiveCell.Offset(1, 0).Range("A1").Select
However, this is not a complete mimic of the down arrow. This subroutine/macro will move into hidden rows, which I do not want.
Each of the following give me an "Object doesn't support this property or method" error:
Selection.MoveDown Unit:=xlCell, Count:=1, Extend:=xlMove
...
Selection.MoveDown Unit:=xlWorksheetCell, Count:=1, Extend:=xlMove
...
Selection.MoveDown xlCell, 1, xlMove
...
Selection.MoveDown xlWorksheetCell, 1, xlMove
The following gives me a syntax error:
Selection.MoveDown(xlWorksheetCell, 1, xlMove)
I can imagine a moderatelymacro that moves the cursor, checks whether the new cell is hidden and, if so, repeats until it is not. However, I have a hard time believing that there isn't a command/method/etc that doesn't simply and easily mimic moving the cursor the way the arrow key does,ignoring hidden rows/columns. For example, I can mimic using the arrow keys while holding down the control key using, g., Selection.End(xlDown).Select. So I want to just mimic moving the cursor with an arrow key as simply as possible.
(This seems like such a simple problem that I'm guessing someone has asked/answered this before. However, if so, and if you mark my question as a duplicate, please indicate where the original answer is, as I've looked and can't find it.)
Assign your shortcut keys to:
Sub MoveDown()
Application.SendKeys "{DOWN}"
End Sub
Not sure what you're really going for, but what about this?
Option Explicit
Sub move_right()
NextVisible "Right"
End Sub
Sub move_left()
NextVisible "Left"
End Sub
Sub move_up()
NextVisible "Up"
End Sub
Sub move_down()
NextVisible "Down"
End Sub
Private Sub NextVisible(direction As String)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim i As Long
Dim r As Range
Set r = ActiveCell
For i = 1 To Rows.Count
On Error Resume Next 'If you're in A1 and try to go up one, it'll error. This skips that error.
Select Case direction
Case "Up"
Set r = r.Offset(-1, 0)
Case "Down"
Set r = r.Offset(1, 0)
Case "Left"
Set r = r.Offset(0, -1)
Case "Right"
Set r = r.Offset(0, 1)
Case Else
Set r = r
End Select
On Error Goto 0
If r.EntireRow.Hidden = False And r.EntireColumn.Hidden = False Then
r.Select
Exit Sub
End If
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
Then, simply assign a shortcut to each one...
So, pressing CTRL+I moves the active cell up.
This was initially written as a solution, but I've since discovered it also has problems. I'll leave it because others have already commented, but note that it is not a solution (at least not in its current form).
I found another web site here that answers my exact question. Here is the solution proposed:
Dim rng As Range
Set rng = Range( _
Cells(ActiveCell.Row + 1, ActiveCell.Column), _
Cells(Rows.Count, ActiveCell.Column) _
)
rng.SpecialCells(xlCellTypeVisible).Cells(1).Select
However, upon closer examination, this does work for moving down, but does not work for moving up. Specifically, you can move down past hidden rows, but it you try to move up past hidden rows the upward movement stops.
For Upwards:
Dim rng As Range
Set rng = Range( _
Cells(1, ActiveCell.Column), _
Cells(ActiveCell.Row - 1, ActiveCell.Column) _
)
Dim rw As Long
rw = rng.SpecialCells(xlCellTypeVisible).Areas( _
rng.SpecialCells(xlCellTypeVisible).Areas.Count _
).Row + rng.SpecialCells(xlCellTypeVisible).Areas( _
rng.SpecialCells(xlCellTypeVisible).Areas.Count).Rows.Count - 1
rng.SpecialCells(xlCellTypeVisible).Cells(rw).Select
Right:
Dim rng As Range
Set rng = Range( _
Cells(ActiveCell.Row, ActiveCell.Column + 1), _
Cells(ActiveCell.Row, Columns.Count) _
)
rng.SpecialCells(xlCellTypeVisible).Cells(1).Select
Left:
Set rng = Range( _
Cells(ActiveCell.Row, 1), _
Cells(ActiveCell.Row, ActiveCell.Column - 1) _
)
Dim rw As Long
rw = rng.SpecialCells(xlCellTypeVisible).Areas( _
rng.SpecialCells(xlCellTypeVisible).Areas.Count _
).Column + rng.SpecialCells(xlCellTypeVisible).Areas( _
rng.SpecialCells(xlCellTypeVisible).Areas.Count).Columns.Count - 1
rng.SpecialCells(xlCellTypeVisible).Cells(rw).Select
I'm going to continue to work on this, but because this is my own answer to my own question, if someone else (who knows more about VBA than I do) wants to take this solution and modify it successfully in your own answer, you have my full blessings to do so.
Note also that even for the successful downward movement this solution produces an "Overflow" error if the row number is greater than 32766.
To move one cell down, provided there is no filter applied where rows are hidden.
Selection.End(xlDown).Select
Selection.End(xlUp).Offset(1).Select