Increment a For loop inside an If statement -VBA - excel

I need to delete columns in a spreadsheet using a loop instead of manually hardcoding those columns in. However all I get is a very unhelpful Next without For error.
Sub test()
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim colNum2 As Integer
colNum2 = 1
For x = 1 To 32
If Range("A1").Value = "Order No." Then
Next colNum
ElseIf Range("B1").Value = "Line No." Then
Next colNum
ElseIf Range("C1").Value = "Order Qty." Then
Next x
ElseIf Range("D1").Value = "PO" Then
Next x
ElseIf Range("E1").Value = "Sched Date" Then
Next x
ElseIf Range("F1").Value = "Sched MFG Line" Then
Next x
ElseIf Range("G1").Value = "Item No." Then
Next x
ElseIf Range("H1").Value = "Item Width" Then
Next x
ElseIf Range("I1").Value = "Item Height" Then
Next x
ElseIf Range("J1").Value = "SL Color" Then
Next x
ElseIf Range("K1").Value = "Frame Option" Then
Next x
End If
'Checks if the cell matches a specific string required by the sorter
'if TRUE should skip through to the next increment of colNum
Columns(colNum2).EntireColumn.Delete
'uses the current number of colNum to delete the current column number
colNum2 = colNum2 + 1
Next x
'increments colNum by one
'Iterates next through the loop
I feel like this would work with say Java or Python so I'm really irritated VBA won't let me do this.
Can someone please explain what is going wrong with this code?

Just use var = var + 1 instead of Next. Next ends the For cycle.
Also you don't need to repeat the variable name on the Next line since it's already in the For line. (For i = 0 To 5 ... Next)
For x = 1 To 32
If Range("A1").Value = "Order No." Then
colNum = colNum +1
ElseIf Range("C1").Value = "Order Qty." Then
x = x + 1
End If
Next
Keep in mind what Scott Cranner said, the Next will also do x=x+1, so if you only want to increment once per cycle, use the Do While cycle instead
x = 1
Do While x <= 32
If Range("A1").Value = "Order No." Then
colNum = colNum +1
ElseIf Range("C1").Value = "Order Qty." Then
x = x + 1
End If
Loop

It seems to me that you want to delete all of the columns that do not match 'a specific string required by the sorter'. In that case, you could loop through all of the columns header labels, deleting the ones that do not match or use a custom left-to-right sort to put all of the non-matching columns to the right and delete then en masse.
Method 1 - Delete non-matching columns
Sub test1()
Dim c As Long, vCOLs As Variant
vCOLs = Array("Order No.", "Line No.", "Order Qty.", "PO", _
"Sched Date", "Sched MFG Line", "Item No.", _
"Item Width", "Item Height", "SL Color", "Frame Option")
With Application
'.ScreenUpdating = False
'.EnableEvents = False
End With
With Worksheets("sheet1")
With .Cells(1, 1).CurrentRegion
'delete from right-to-left or risk missing one
For c = .Columns.Count To 1 Step -1
If IsError(Application.Match(.Cells(1, c).Value2, vCOLs, 0)) Then
.Columns(c).EntireColumn.Delete
End If
Next c
End With
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Method 2 - Custom sort, then offset and delete
Sub test2()
Dim vCOLs As Variant
vCOLs = Array("Order No.", "Line No.", "Order Qty.", "PO", _
"Sched Date", "Sched MFG Line", "Item No.", _
"Item Width", "Item Height", "SL Color", "Frame Option")
With Application
'.ScreenUpdating = False
'.EnableEvents = False
.AddCustomList ListArray:=vCOLs
End With
With Worksheets("sheet1")
With .Cells(1, 1).CurrentRegion
'custom sort to bring the important fields to the left
.Cells.Sort Key1:=.Rows(1), Order1:=xlAscending, _
Orientation:=xlLeftToRight, Header:=xlNo, _
OrderCustom:=Application.GetCustomListNum(vCOLs)
'offset and delete the unwanted columns
With .Offset(0, Application.Match(vCOLs(UBound(vCOLs)), .Rows(1), 0))
.EntireColumn.Delete
End With
End With
End With
With Application
.DeleteCustomList .GetCustomListNum(vCOLs)
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
With either method you are simply listing the columns you want to keep and removing the rest.
There is a twist between .Cells.Sort.SortFields.Add and .Cells.Sort that usually generates some confusion. The .SortFields.Add method uses a CustomOrder:= parameter and the Range.Sort method uses a OrderCustom:= parameter. The two are most definitely NOT the same but often get used interchangeably with disastrous results.

I suspect you are trying to delete columns based on their text values in row 1. This will give you what you want, just put all the text references that you want to delete in the CASE statement.
Option Explicit
Sub DeleteColumns()
Dim colNum As Integer
colNum = 1
Do While Range(alphaCon(colNum) & 1).Value <> ""
Select Case Range(alphaCon(colNum) & 1).Value
Case "ColumnIDontWant", "AnotherColumnIDontWant"
Columns(colNum).EntireColumn.Delete
End Select
colNum = colNum + 1
Loop
End Sub
Public Function alphaCon(aNumber As Integer) As String
' Fixed version 27/10/2011
Dim letterArray As String
Dim iterations As Integer
letterArray = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
If aNumber <= 26 Then
alphaCon = (Mid$(letterArray, aNumber, 1))
Else
If aNumber Mod 26 = 0 Then
iterations = Int(aNumber / 26)
alphaCon = (Mid$(letterArray, iterations - 1, 1)) & (Mid$(letterArray, 26, 1))
Else
'we deliberately round down using 'Int' as anything with decimal places is not a full iteration.
iterations = Int(aNumber / 26)
alphaCon = (Mid$(letterArray, iterations, 1)) & (Mid$(letterArray, (aNumber - (26 * iterations)), 1))
End If
End If
End Function

Related

How to use Select Case for Text String

I'd like to have a case that reads a text string such as "Net 75 from 1st of following month", if that cell contains this value it will do the following case.
My code works when the value is say "P" but once I make it long it no longer works?
Option Explicit
Sub CalcColB()
Dim x As Long
Application.ScreenUpdating = False
For x = 1 To Cells(Rows.Count, "F").End(xlUp).Row
Select Case UCase(Cells(x, 6))
Case "Net 75 from 1st of following month"
Cells(x, 2).FormulaR1C1 = "=A2*1.8"
Case "F"
Cells(x, 2).FormulaR1C1 = "=RC[-1]*1000"
Case Else
Cells(x, 2).Formula = "="""""
End Select
Next x
Application.ScreenUpdating = True
End Sub

input and check of values from input box

please help where is the error.
loop without IF?
I need to load the code, check the first 2 values match the cell. Check that you do not duplicate in column A. And retrieve the codes until the required number is reached.
Thank you
My Code:
Sub novy()
Dim aText(1) As Variant
Dim n As Integer
Dim vstup As String
vstup = InputBox(aText(x))
Set hledat = Range("A:A").Find(what:=vstup, LookIn:=xlValues, LookAt:=xlWhole)
If vstup = "" Then ' in case the use press "Cancel"
i = MsgBox("Chcete ukončit načítání?", vbYesNo)
Select Case i
Case vbYes
Exit Sub
Case vbNo
Call novy
End Select
ElseIf Left(vstup, 2) <> Range("D3").Formula Then
i = MsgBox("jiný modul!", vbExclamation)
ElseIf hledat Is Nothing Then
For n = 1 To 10
aText(1) = "Načti kód"
Sheets("data").Select
aLastRow = Cells(1, 1).CurrentRegion.Rows.Count + 1
For x = 1 To 1
Cells(aLastRow, x) = vstup
Next
Cells(10, 9) = n
'MsgBox n
Next n
MsgBox "Bedna je hotová"
Else
i = MsgBox("modul byl už načten!", vbExclamation)
End If
End Sub
You have an error on the the two last for loops. you dont need 2 either with an "x" from 1 to 1..
For n = 1 To 10
aText(1) = "Načti kód"
Sheets("data").Select
aLastRow = Cells(1, 1).CurrentRegion.Rows.Count + 1
Cells(aLastRow, 1) = vstup
Next

VBA Userform Listbox Conditional Logic Not Working as Intended

I have a Userform with a listbox for which I am using conditional logic to determine output values to the sheet of selected or non-selected items in the listbox. The issue is that when the Textbox (Tbl_AliasName) is blank, the code executes this:
ElseIf .Selected(k) = True And Tbl_AliasName = vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Trim(Cells(2, 1).Value2) & "." & .Column(1, k)
But if Tbl_AliasName is not blank then the code does nothing, but it is supposed to do this:
ElseIf .Selected(k) = True And Tbl_AliasName <> vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Tbl_AliasName & "." & .Column(1, k)
I have used several variations of If statements, and non of which have worked.
Below is My Code:
Option Explicit
Public Tbl_AliasName As String
Tbl_AliasName = Trim(UserForm_Finder.txtConcat.Value)
Private Sub BtnConcat_Click()
Dim k As Long, lstbxRow As Long, LR As Long
lstbxRow = 1
'****************
'This if statement works perfectly
If (Cells(2, 1).Value2 = vbNullString Or Cells(2, 2).Value2 = vbNullString) _
And Tbl_AliasName = vbNullString Then
MsgBox "You must Search for a Table or Column first.", _
vbExclamation, "Error Encountered"
Exit Sub
ElseIf (UserForm_Finder.ListBx_TblsCols.ListCount = 0 And Tbl_AliasName <> vbNullString) Then
MsgBox "You must Search for a Table or Column first.", _
vbExclamation, "Error Encountered"
'(Cells(2, 1).Value2 = vbNullString Or Cells(2, 2).Value2 = vbNullString) And _
Exit Sub
End If
With UserForm_Finder.ListBx_TblsCols
For k = 0 To .ListCount - 1
'****************
This is where the problems begin
If .Selected(k) = False Then
MsgBox "You must Select 1 or more items from the list box.", _
vbExclamation, "Error Encountered"
Exit Sub
ElseIf .Selected(k) = True And Tbl_AliasName <> vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Tbl_AliasName & "." & .Column(1, k)
ElseIf .Selected(k) = True And Tbl_AliasName = vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Trim(Cells(2, 1).Value2) & "." & .Column(1, k)
End If
Next k
End With
End Sub
My goal is to do the following:
If a Textbox (Tbl_AliasName) is not blank and the user has selected one or more items in the listbox (ListBx_TbleCols) then concatenate the Tbl_AliasName to the selected items in the listbox
If Tbl_AliasName is blank, then use the value in Cells(2,1) to concatenate to the selected Items in the list box.
I have tried the following additions:
Dim LstBxItemSelected As Boolean
'This was placed in the for loop
LstBxItemSelected = True
'this was placed outside the for loop
If LstBxItemSelected = False Then
MsgBox "You must Select 1 or more items from the list box.", _
vbExclamation, "Error Encountered"
Exit Sub
End If
Is there a better way to tell if items are selected, because I feel that the way I have it structured in my loop, the code will throw the error if everything isn't selected? Thank you in advance for any ideas, answers, or suggestions!
Note: The Listbox is populated by the click of another button on the userform which calls the following sub:
Sub FillLstBxCols()
Dim ListBx_Target As MSForms.ListBox
Dim rngSource As Range
Dim LR As Long
If Cells(2, 1).Value2 <> vbNullString Then
LR = Worksheets("New TRAX").Cells(Rows.Count, 2).End(xlUp).Row
'Set reference to the range of data to be filled
Set rngSource = Worksheets("New Trax").Range("A" & 2 & ":" & "B" & LR)
'Fill the listbox
Set ListBx_Target = UserForm_Finder.ListBx_TblsCols
With ListBx_Target
.RowSource = rngSource.Address
End With
End If
End Sub
Hard to say without sample data and expected results, but I think this is what you're looking for:
Private Sub btnConcat_Click()
Dim ws As Worksheet
Dim bSelected As Boolean
Dim sConcat As String
Dim i As Long, lRowIndex As Long
Set ws = ActiveWorkbook.Sheets("New TRAX")
lRowIndex = 1
bSelected = False
sConcat = Trim(Me.txtConcat.Text)
If Len(sConcat) = 0 Then sConcat = Trim(ws.Cells(2, "A").Value)
If Len(sConcat) = 0 Then
MsgBox "You must Search for a Table or Column first.", vbExclamation, "Error Encountered"
Exit Sub
End If
For i = 0 To Me.ListBx_TblsCols.ListCount - 1
If Me.ListBx_TblsCols.Selected(i) Then
If bSelected = False Then
bSelected = True
ws.Range("C2", ws.Cells(ws.Rows.Count, "C")).Clear 'clear previous concat results (delete this line if not needed)
End If
lRowIndex = lRowIndex + 1
ws.Cells(lRowIndex, "C").Value = sConcat & "." & Me.ListBx_TblsCols.List(i)
End If
Next i
If bSelected = False Then MsgBox "Must select at least one item from the list"
End Sub

VBA vbYesNo Inquiry

I am trying to create a message box that will give the user the option to continue or stop if their search comes up with more than 1000 results. I have the message box made, but I don't know how to code the vbYes and the vbNo to either continue on with the code (vbYes) or to end the script (vbNO).
Here is my code.
Sub FindOne()
Range("B19:J5000") = ""
Application.ScreenUpdating = False
Dim k As Integer, EndPasteLoopa As Integer, searchColumn As Integer, searchAllCount As Integer
Dim myText As String
Dim totalValues As Long
Dim nextCell As Range
Dim searchAllCheck As Boolean
k = ThisWorkbook.Worksheets.Count
myText = ComboBox1.Value
Set nextCell = Range("B20")
If myText = "" Then
MsgBox "No Address Found"
Exit Sub
End If
Select Case ComboBox2.Value
Case "SEARCH ALL"
searchAllCheck = True
Case "EQUIPMENT NUMBER"
searchColumn = 1
Case "EQUIPMENT DESCRIPTION"
searchColumn = 3
Case "DUPONT NUMBER"
searchColumn = 6
Case "SAP NUMBER"
searchColumn = 7
Case "SSI NUMBER"
searchColumn = 8
Case "PART DESCRIPTION"
searchColumn = 9
Case ""
MsgBox "Please select a value for what you are searching by."
End Select
For I = 2 To k
totalValues = Sheets(I).Cells(Rows.Count, "A").End(xlUp).Row
ReDim AddressArray(totalValues) As String
If searchAllCheck Then
searchAllCount = 5
searchColumn = 1
Else
searchAllCount = 0
End If
For qwerty = 0 To searchAllCount
If searchAllCount Then
Select Case qwerty
Case "1"
searchColumn = 3
Case "2"
searchColumn = 6
Case "3"
searchColumn = 7
Case "4"
searchColumn = 8
Case "5"
searchColumn = 9
End Select
End If
For j = 0 To totalValues
AddressArray(j) = Sheets(I).Cells(j + 1, searchColumn).Value
Next j
If totalValues > 1000 Then
Results = MsgBox("Your Search has Returned Over 1000 Results. Continuing Could Cause Excel to Slow Down or Crash. Do you Wish to Continue?", vbYesNo + vbExclamation, "Warning")
End If
If Results = vbNo Then
End
End If
If Results = vbYes Then
For j = 0 To totalValues
If InStr(1, AddressArray(j), myText) > 0 Then
EndPasteLoop = 1
If (Sheets(I).Cells(j + 2, searchColumn).Value = "") Then EndPasteLoop = Sheets(I).Cells(j + 1, searchColumn).End(xlDown).Row - j - 1
For r = 1 To EndPasteLoop
Range(nextCell, nextCell.Offset(0, 8)).Value = Sheets(I).Range("A" & j + r, "I" & j + r).Value
Set nextCell = nextCell.Offset(1, 0)
Next r
End If
Next j
Else
End
End If
Next qwerty
Next I
Debug.Print tc
Application.ScreenUpdating = True
End Sub
If I understood your problem, you have to compare the "Results" variable if is vbYes or vbNo.
Below a little and simple example.
If MsgBox("Continue?", vbYesNo,"Confirmation") = vbYes Then
'code if yes
Else
'End
End If
Hope that helps. ;)
vbYes is a constant, a member of an enum called VbMsgBoxResult that defines a bunch of related constants, including vbYes and vbNo.
If vbYes Then
That's like saying
If 42 Then
You have a constant expression that evaluates to a Long integer, and an If statement works with a Boolean expression that evaluates to a Boolean value (True/False).
You need to compare vbYes to something to get that Boolean expression.
If Results = vbYes Then

Preventing duplicates in a column regardless of the case of the entry

I type three entries in specific cells
[A2,B2,C2] and run code to take this data to the first empty row in a table.
The code also prevents duplicates based on the entered value in cell B2. If it already exists in the range (B2:B5000) it prevent duplicates.
The problem is it does not ignore the case.
For example:
I enter value "Acetic Acid"
After awhile I add "acetic Acid" or change any letter case.
The code adds it normally without preventing.
How do I ignore the letter case?
Sub tarheel()
LastRow = Range("A10000").End(xlUp).Row + 1
LR = Range("b10000").End(xlUp).Row + 1
For r = 5 To LR
If Cells(r, 2) = Range("b2") Then MsgBox "This Item Name already exist, No shift will done": Exit Sub
Next
Cells(LastRow, 1).Value = Range("A2").Value
Cells(LastRow, 2).Value = Range("B2").Value
Cells(LastRow, 3).Value = Range("C2").Value
Range("A2:C2").Select
Selection.ClearContents
Range("A2").Select
End Sub
thanks for all your replies and i will try it too and give feedback to you.
i could figure it out by adding this line at the top of my module.
Option Compare Text
and it fixed my problem.
thanks
To change case in VBA, you have LCase and UCase, which will respectively change all of your string into lower case or upper case.
Here is your code with the change and got ride of the useless (and ressource-greedy) select at the end :
Sub tarheel()
LastRow = Range("A10000").End(xlUp).Row + 1
LR = Range("b10000").End(xlUp).Row + 1
IsIn = False
For r = 5 To LR
If LCase(Cells(r, 2)) = LCase(Range("b2")) Then _
MsgBox "This Item Name already exist, No shift will done": Exit Sub
Next
Cells(LastRow, 1).Value = Range("A2").Value
Cells(LastRow, 2).Value = Range("B2").Value
Cells(LastRow, 3).Value = Range("C2").Value
Range("A2:C2").ClearContents
'Range("A2").Select
End Sub
You can replace your loop that compares for existing values with a case insensitive one by forcing both values to either upper or lower case.
For r = 5 To LR
If lcase(Cells(r, 2)) = lcase(Range("b2")) Then
MsgBox "This Item Name already exist, No shift will done"
Exit Sub
end if
Next
It may be more efficient to use a case-insensitive worksheet function to check the whole range at once.
If cbool(application.countif(Range("B5:B" & LR), Cells(r, 2))) Then
MsgBox "This Item Name already exist, No shift will done"
Exit Sub
end if
Another possible:
If not iserror(application.match(Cells(r, 2), Range("B5:B" & LR), 0)) Then
MsgBox "This Item Name already exist, No shift will done"
Exit Sub
end if
Sub tarheel()
LastRow = Range("A10000").End(xlUp).Row + 1
LR = Range("b10000").End(xlUp).Row + 1
IsIn = False
For r = 5 To LR
If LCase(Cells(r, 2)) = LCase(Range("b2")) Then _
MsgBox "This Item Name already exist, No shift will done": Exit Sub
Next
Cells(LastRow, 1).Value = Range("A2").Value
Cells(LastRow, 2).Value = Range("B2").Value
Cells(LastRow, 3).Value = Range("C2").Value
Range("A2:C2").ClearContents
'Range("A2").Select
End Sub

Resources