Excel VBA - using SELECT CASE but now need an array - excel

I've currently got the code below. There can only currently be seven values for "ins" and so the code suffices, however as of next month I have been told that there will be over 900 values!
I assume that rather than writing another 900 case statements I could use an array of some sort. Can anyone give me a nudge in the right direction?
Private Sub test()
Dim i As Long
Dim lr As Long
Dim ins As String
lr = Range("A" & Rows.Count).End(xlUp).Row
For i = 6 To lr
Select Case Cells(i, 20)
Case Is = ""
ins = Mid(Cells(i, 11), 14, 2)
Select Case Cells(i, 10)
Case "Inx", "ComInx"
Select Case Cells(i, 9)
Case "EINX"
Select Case ins
Case "LD"
Cells(i, 9).Value = "SR"
Case "GP"
Cells(i, 9).Value = "GAMA"
Case "AV"
Cells(i, 9).Value = "NU"
Case "AX"
Cells(i, 9).Value = "AXC"
Case "MZ"
Cells(i, 9).Value = "MZE"
Case "AD"
Cells(i, 9).Value = "AGD"
Case "AG"
Cells(i, 9).Value = "AG"
End Select
End Select
End Select
End Select
Next
End Sub

I would use a dictionary object for this. Here is a proof-of-concept based on your lines:
Private Sub test()
Dim i As Long
Dim lr As Long
Dim ins As String
Dim rngCases As Range, rngCases2 As Range, rngCase As Range
Dim dicCases As Dictionary
lr = Range("A" & Rows.Count).End(xlUp).Row
' rngCases stores the possible values of ins
' Here I assume they are stored in col 40
Set rngCases = Range(Cells(6, 40), Cells(lr, 40))
' rngCases2 stores the values you want to map for each value of ins.
' Here I assume they are stored in col 41
' No of entries = No of entries of rngCases
Set rngCases2 = Range(Cells(6, 41), Cells(lr, 41))
Set dicCases = New Dictionary
For Each rngCase In rngCases
If Not dicCases.Exists(rngCase.Value) Then
dicCases.Add Key:=rngCase.Value, Item:=rngCases2.Value
End If
Next rngCase
For i = 6 To lr
Select Case Cells(i, 20)
Case Is = ""
ins = Mid(Cells(i, 11), 14, 2)
Select Case Cells(i, 10)
Case "Inx", "ComInx"
Select Case Cells(i, 9)
Case "EINX"
' We simply need to refer to the mapped value of ins
If dicCases.Exists(ins) then
Cells(i, 9) = dicCases.Item(ins)
Else
' Throw an error or do something here
End If
End Select
End Select
End Select
Next
End Sub
To enable the Dictionary, go to Tools->References and select Microsoft Scripting Runtime.
I hope this gets you started!

Related

Start at Row A19 instead of Row A1

I am trying to have an entry data userform where the input starts at "A19" and will end at row "A30" once the empty rows get filled 1 by 1, instead of the current situation where it starts at "A1" and goes unrestricted.
Private Sub cmdAdd_Click()
Dim wks As Worksheet
Dim AddNew As Range
Set wks = ActiveSheet
Set AddNew = wks.Range("A2:A65565").End(xlUp).Offset(1, 0)
AddNew.Offset(0, 2).Value = txtCAC.Text
AddNew.Offset(0, 4).Value = txtName.Text
AddNew.Offset(0, 5).Value = txtType.Text
AddNew.Offset(0, 6).Value = txtClass.Text
AddNew.Offset(0, 7).Value = txtDate.Text
AddNew.Offset(0, 8).Value = txtParent.Text
AddNew.Offset(0, 9).Value = txtManagement.Text
AddNew.Offset(0, 10).Value = txtSuccess.Text
AddNew.Offset(0, 12).Value = txtPercentage.Text
AddNew.Offset(0, 21).Value = txtCommittment.Text
AddNew.Offset(0, 38).Value = txtContribution.Text
AddNew.Offset(0, 40).Value = txtRedemption.Text
lstDisplay.ColumnCount = 41
lstDisplay.RowSource = "A2:A65356"
End Sub
As apparently your goal is to overwrite an adjacent fixed target range
with a complete set of textbox entries, I'd propose the following steps:
[0.] Define the fixed start cell in target cell e.g. via set tgt = Sheet1.Range("A19").
[1. a)] Split a list of needed textbox names thus getting a 1-dimensional array, which btw will be 0-based automatically.
[1. b)] Provide for data by a 2-dim data array and make it zero-based, too in order to
synchronize both array counters in the following loop (1.c).
[1. c)] Fill the data array rows with all textbox contents by a For..Next loop
and check for not allowed zero-length inputs;
if there are any display a warning message and redirect focus to the empty textbox.
[2.] Eventually dump back the data array to the chosen target range
by using the number of listed textbox controls cnt to .Resize the target range (e.g. 12 in OP).
Private Sub cmdAdd_Click()
'0. Define fixed start cell in target range
dim tgt as Range
set tgt = Sheet1.Range("A19") ' change to any wanted sheet Code(Name)
'1. a) split a list of needed textbox names getting a 1-dim 0-based array automatically
Dim myTextboxes As Variant
myTextboxes = Split( _
"txtCAC,txtName,txtType,txtClass,txtDate,txtParent,txtManagement," & _
"txtSuccess,txtPercentage,txtCommittment,txtContribution,TxtRedemption", _
",")
Dim cnt As Long
cnt = UBound(myTextboxes) + 1 ' count number of textboxes
' b) provide for data by a 2-dim data array (make it zero-based, too)
Dim data As Variant
ReDim data(0 To cnt - 1, 0 To 0) ' define dimensions holding data
' c) fill data array rows with all textbox contents
Dim i As Long, ctrl As MSForms.Control
For i = LBound(data) To UBound(data) ' i.e. 0 To 11
Set ctrl = Me.Controls(myTextboxes(i)) ' set control to memory
data(i, 0) = ctrl.Text ' get textbox content
' check for complete entries or exit sub
If Len(Trim(data(i, 0))) = 0 Then ' check for zero-length input
MsgBox "Fill in empty Textbox(es) first!", vbExclamation, ctrl.Name
ctrl.SetFocus ' set focus to empty box
Exit Sub ' escape procedure
End If
Next
'2. dump data to target range
tgt.Resize(cnt, 1) = data ' write data
End Sub
Further hints
I think there will be to need to define a RowSource (btw better to use "Sheet1!A19:A30" if you are overwriting all data anyway by command button.
Side note: Prefer to get a last row cell via e.g. Sheet1.Range("A" & .Rows.Count).End(xlUp) or the row index via .Range("A" & .Rows.Count).End(xlUp).Row instead of coding a fixed rows count (current sheets have at about 1 million). You might be interested in reading Finding last used cell
`
Dim wks As Worksheet
Dim AddNew As Range
Set wks = ActiveSheet
Dim h As Integer
h = wks.Range("C65356").End(xlUp).Row
If h < 18 Then h = 18
if h > 30 then exit Sub
Set AddNew = wks.Range("A" & h)
AddNew.Offset(1, 2).Value = txtCAC.Text
AddNew.Offset(1, 4).Value = txtName.Text
AddNew.Offset(1, 5).Value = txtType.Text
AddNew.Offset(1, 6).Value = txtClass.Text
AddNew.Offset(1, 7).Value = txtDate.Text
AddNew.Offset(1, 8).Value = txtParent.Text
AddNew.Offset(1, 9).Value = txtManagement.Text
AddNew.Offset(1, 10).Value = txtSuccess.Text
AddNew.Offset(1, 12).Value = txtPercentage.Text
AddNew.Offset(1, 21).Value = txtCommittment.Text
AddNew.Offset(1, 38).Value = txtContribution.Text
AddNew.Offset(1, 40).Value = txtRedemption.Text
'lstDisplay.ColumnCount = 41
'lstDisplay.RowSource = "A2:A65356"

How to find a value in column and paste ranges from other worksheets into its adjacent columns

The end goal for my project is that the user will be able to select a value from a ComboBox to fill out a report on a Summary Tab. The report will consist of 3, 3 cell ranges (divided into 3 1x3 ranges on 3 separate worksheets).
I want to find the row with the value the user selected in the ComboBox and then set the 9 cells to the right of that value equal to the values in the range mentioned previously.
I've tried a couple of different ways of doing this, but I'll include the code I most recently worked on below:
Private Sub OKButton1_Click()
Dim userValue, rangeOne, rangeTwo, rangeThree
Dim i As Long
i = 4
userValue = ComboBox1.Value
Set rangeOne = Sheets("Sheet2").Range(Range("F23:H23")
Set rangeTwo = Sheets("Sheet3").Range("F90:H90")
Set rangeThree = Sheets("Sheet4").Range("F17:H17")
While Sheets("Reports").Range(cells(i,1)).Value <> ""
If Sheets("Reports").Range(cells(i, "A")).Value = "userValue" Then
Set Sheets("Reports").Range(Cells(i, "B:E")) = rangeOne
Set Sheets("Reports").Range(Cells(i, "F:I")) = rangeOne
Set Sheets("Reports").Range(Cells(i, "J:M")) = rangeOne
End If
i = i + 1
Wend
Unload UserForm2
End Sub
Any Ideas on how I can improve this or get it working? Currently getting 1004 errors.
Two words of advice when working with excel:
always make variables for each sheet/book you need to work with
Avoid using ranges and objects if you can. It is much easier to iterate over individual cells using an array and a for loop like I did below.
I was a bit confused on exactly what you needed done, so you will need to modify this slightly to fit your ranges/where you want the data to go. If you are confused or need further assistance let me know and I'll update this.
Dim userValue
Dim xrow As Long, ws1 As Worksheet, ws2 As Worksheet, ws3 as Worksheet, ws4 as Worksheet
Dim arrData() as variant
set ws1 = Worksheets("Report")
set ws2 = Worksheets("Sheet2")
set ws3 = Worksheets("Sheet3")
set ws4 = Worksheets("Sheet4")
userValue = ComboBox1.Value
xrow = 1
ws2.activate
'the InStr function checks if the first condition contains the second, and when it does, it returns 1, which in turn triggers the if statement
for x = 1 To ws2.Cells(rows.count, 1).end(xlup).row
if InStr(1, Cells(x, 1), userValue) > 0 Then
arrData(0) = ws2.Cells(x, 2).value
arrData(1) = ws2.Cells(x, 3).value
arrData(2) = ws2.Cells(x, 4).value
else:
end if
next x
ws3.activate
for x = 1 To ws3.Cells(rows.count, 1).end(xlup).row
if InStr(1, Cells(x, 1), userValue) > 0 Then
arrData(3) = ws3.Cells(x, 2).value
arrData(4) = ws3.Cells(x, 3).value
arrData(5) = ws3.Cells(x, 4).value
else:
end if
next x
ws4.activate
for x = 1 To ws4.Cells(rows.count, 1).end(xlup).row
if InStr(1, Cells(x, 1), userValue) > 0 Then
arrData(6) = ws4.Cells(x, 2).value
arrData(7) = ws4.Cells(x, 3).value
arrData(8) = ws4.Cells(x, 4).value
else:
end if
next x
ws1.activate
ws1.Cells(xrow, 1) = userValue
for y = 0 To 8
ws1.Cells(xrow, y+1).value = arrData(y)
next y
xrow = xrow + 1
For x = 1 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
If InStr(1, Cells(x, 1), UserValue) > 0 Then
ws1.Cells(x, 2) = ws2.Cells(23, 6).Value
ws1.Cells(x, 3) = ws2.Cells(23, 7).Value
ws1.Cells(x, 4) = ws2.Cells(23, 8).Value
ws1.Cells(x, 6) = ws3.Cells(90, 6).Value
ws1.Cells(x, 7) = ws3.Cells(90, 7).Value
ws1.Cells(x, 8) = ws3.Cells(90, 8).Value
ws1.Cells(x, 10) = ws4.Cells(18, 6).Value
ws1.Cells(x, 11) = ws4.Cells(18, 7).Value
ws1.Cells(x, 12) = ws4.Cells(18, 8).Value
Else:
End If
Next x
The above is what I'm working with now in place of the while loop.

customize sorting of a column in vba to show an item first

I have a big table in excel, which contains about 8000 rows of data. I am working on a procedure to enable the users to receive a pdf copy of what they are looking for. (A detail list related to a work order).
I tried two different approaches, first copying the work order items after filtering it to a third sheet and then copying selected fields of data to the final form. It was good and fast.
second, after filter directly copying data of unhidden rows to the final form. (also more sort and remove duplicated items happen too)
The second one is very time killing (3 to 5 minutes) and very heavy.
Now, I am thinking of first sorting the data in a way that my desired item (what the user is looking for) comes to the first of table so after the filter, I just ask the loop to go until a visible number of rows, not until the end of rows.
Has anyone any idea, or better solution?
Cheers and merry Christmas!
Sub kit_Click()
' On Error GoTo Errorhandler
Dim wc As String
Dim c As Integer
Dim tbl As Range
Dim sel As Range
Dim des As Range
Dim m As Integer
Dim j As Integer
Dim aggrow As Integer
Dim varResult As Variant
Dim kf As Worksheet
Set kf = Worksheets("Kit Form")
a = ""
' Application.ScreenUpdating = False
' finding W/B code to prepare
If Not Intersect(ActiveCell, Range("d2:d3")) Is Nothing Then
a = Cells(2, 7).Value
GoTo body
ElseIf ActiveCell.Row < 6 Then a = InputBox("please specify the W/B you want to prepare KIT form for that", "W/B Number")
ElseIf ActiveCell.Row > ActiveSheet.UsedRange.Rows.Count Then a = InputBox("please specify the W/B you want to prepare KIT form for that", "W/B Number")
Else: a = Cells(ActiveCell.Row, 2).Value
End If
body:
On Error GoTo skip
wc = WorksheetFunction.VLookup(a, Range("b5:c1000"), 2, 0)
skip:
If a = "" Or a = "0" Then
a = InputBox("please specify the W/B you want to prepare KIT form for that", "W/B Number")
Else
' Cleaning KIT FORM
If Not kf.ListObjects("KitForm").DataBodyRange Is Nothing Then kf.ListObjects("KitForm").DataBodyRange.EntireRow.Delete
' Filtering the W/B Kittable items
With Sheets("FTV3")
.Range("tbl").AutoFilter Field:=3, Criteria1:="*" & a & "*", Operator:=xlFilterValues
.Range("tbl").AutoFilter Field:=25, Criteria1:="OK", Operator:=xlFilterValues
' Unhidding the Columns and copying the header row
.Cells.EntireColumn.Hidden = False
' Copying the data to Form
lstrw = .Cells(Rows.Count, 8).End(xlUp).Row
kf.Cells(2, 2) = a
kf.Cells(1, 4) = wc
m = 1
For i = 2 To lstrw
If .Rows(i).EntireRow.Hidden Then
m = m + 1
Else
kf.Rows(i - m + 4).RowHeight = 25
kf.Cells(i - m + 4, 1).Value = i - m
If .Cells(i, 21).Value = "_N/A" Then
kf.Cells(i - m + 4, 2) = "'"
Else
kf.Cells(i - m + 4, 2) = .Cells(i, 21)
End If
kf.Cells(i - m + 4, 3).Value = .Cells(i, 4).Value
If .Cells(i, 4).Value <> "_Book" Then kf.Cells(i - m + 4, 4).Value = .Cells(i, 26).Value
Worksheets("Kit Form").Cells(i - m + 4, 5).Value = .Cells(i, 7).Value
If .Cells(i, 8).Value <> "N/T" Then kf.Cells(i - m + 4, 6).Value = .Cells(i, 8).Value
If .Cells(i, 12).Value <> "_N/A" Then ttt = .Cells(i, 12) 'Or .Cells(i, 22).Value <> ""
kf.Cells(i - m + 4, 7).Value = "(( " & .Cells(i, 27).Value & " ))" & Chr(10) & ttt
kf.Rows(i - m + 4).AutoFit
If kf.Rows(i - m + 4).RowHeight < 25 Then kf.Rows(i - m + 4).RowHeight = 25
End If
Next
.Range("A:B,S:ac").EntireColumn.Hidden = True
aggrow = kf.Cells(Rows.Count, 1).End(xlUp).Row - 4
.Range("tbl").AutoFilter
End With
Call remove_duplicate
R = MsgBox("Successfuly Total of " & lstrw - m - 1 & " Items, aggregated in " & aggrow & " Rows of material Copied to the Kit Form " & Chr(10) & Chr(10) & "Do you want an PDF version of The form being prepared for you?", vbYesNo, "Result")
If R = 6 Then Call export_pdf
End If
End Sub

Applying if statement to range of cells using VBA

I have a small range of cells, C6:C10. I'm trying to apply an if statement to this range of cells using VBA code. Currently, my code takes the output of the if statement for the first cell (C6), and replicates that value for cells C7:C10. The if statement is correct, I'm just not sure how to apply it to a range of cells in a column.
Sub Cleanup()
Dim Segment As String
Dim i As Integer
Segment = ActiveCell(6, 3).Value
For i = 6 To 10
If Right(Left(Segment, 6), 1) = "/" Then
ActiveCell(i, 3).Value = Left(Segment, 5)
Else
ActiveCell(i, 3).Value = Left(Segment, 6)
End If
Next i
End Sub
It should be fine if you use Cells instead of ActiveCell, except that you'll have to change your loop to go from 7 to 10 or else it will over-write the original cell as well as C7:C10.
Sub Cleanup()
Dim Segment As String
Dim i As Integer
Segment = Cells(6, 3).Value
For i = 7 To 10
If Right(Left(Segment, 6), 1) = "/" Then
Cells(i, 3).Value = Left(Segment, 5)
Else
Cells(i, 3).Value = Left(Segment, 6)
End If
Next i
End Sub
Sub Cleanup()
Dim Segment As String
Dim i As Integer
Segment = Cells(i, 3).Value
For i = 7 To 10
If Right(Left(Segment, 6), 1) = "/" Then
cells(i, 3).Value = Left(Segment, 5)
Else
Cells(i, 3).Value = Left(Segment, 6)
End If
Next i
End Sub
here three (out of many other) possible codes, in simplicity order (the last being more simple than the first):
Option Explicit
Sub Cleanup()
Dim Segment As String
Dim i As Integer
For i = 6 To 10
Segment = Cells(i, 3).Value '<== Cells(i, 3) is the current cell as per the current row (i)
If Mid(Segment, 6, 1) = "/" Then
Cells(i, 3).Value = Left(Segment, 5)
Else
Cells(i, 3).Value = Left(Segment, 6)
End If
Next i
End Sub
Sub Cleanup2()
Dim i As Integer
For i = 6 To 10
With Cells(i, 3) 'avoid repetitions (and a variable, too) by using 'With' keyword and implying 'Cells(i, 3)' preceeds every dot (".") till next 'End With" statement
If Right(Left(.Value, 6), 1) = "/" Then
.Value = Left(.Value, 5)
Else
.Value = Left(.Value, 6)
End If
End With
Next i
End Sub
Sub Cleanup3()
Dim i As Integer
For i = 6 To 10
With Cells(i, 3)
.Value = Left(.Value, IIf(Mid(.Value, 6, 1) = "/", 5, 6)) ' use Iif function to avoid multiple lines. Also use 'Mid' function in lieu of 'Right(Left(..))'
End With
Next i
End Sub

Tell loop to only paste in one cell and not all the way down

I'm trying to make a loop that will go thru this data set.
This is how the output should look.
Im still getting the hang of loops, but this is what i have so far:
Private Sub CommandButton1_Click()
Dim i As Long, j As Long, k As Byte, iLines As Long
j = 1
For i = 1 To 25
For k = 1 To 8
If k = 1 Then
Cells(j, 10).Value = Len(Cells((j + 2), 1).Value) - Len(Replace(Cells((j + 2), 1).Value, ",", "")) + 1
Cells(i, 11).Value = "SET"
Cells(i, 12).Value = Cells(i, 1).Value
End If
Next k
Next i
End Sub
My problem is on my loop output at the moment. It only counts the commas in the first data set and not the other ones. Also where it outputs SET it copies down instead of just putting it in one cell. See Below.
I will probably have more question as i progress along. Thanks in advance for the help!
Try this:
Whenever possible get rid of the loop. I replaced it with a find to find the next cell with "HW" in it. It will automatically step from one "HW" to the Next.
When using steps anchor everything on the one row and expand selection using resize.
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim i As Long
Dim k As Long
Set ws = ActiveSheet
With ws
For i = 1 To 200
If Left(.Cells(i, 1).Value, 2) = "HW" Then
On Error Resume Next
k = .Range(.Cells(i + 1, 1), .Cells(200, 1)).Find("HW").Row
On Error GoTo 0
If k <= i Then k = 200
.Cells(i, 10).Value = Len(Cells((i + 2), 1).Value) - Len(Replace(Cells((i + 2), 1).Value, ",", "")) + 1
.Cells(i, 11).Value = "SET"
.Cells(i, 12).Resize(k - i).Value = .Cells(i, 1).Resize(k - i).Value
i = k - 1
End If
Next i
End With
End Sub

Resources