So I am using the following code to make a bunch of decisions based on values in table columns. I have taken each table column containing values that go into making the decision in variant arrays. And then used a combination of for and while loops to assign decisions in the ans() variant array.
The problem is, every time I run the macro my Excel hangs.
I tried the usual method of adding automatic calculations and disabling events and screen updates. But it did not help the matter in any way. I tried simplifying my code as well but this is about as much simplification I can include while still achieving what I would like the code to. Can someone please tell me what else I can do to make this run?
Dim sh As Worksheet
Set sh = Sheets("LOGIC")
Dim t As ListObject
Set t = sh.ListObjects("Table8")
n = t.ListRows.Count
Dim rel() As Variant
rel = t.ListColumns(61).DataBodyRange.Value
Dim dc() As Variant
dc = t.ListColumns(62).DataBodyRange.Value
Dim t_req() As Variant
t_req = t.ListColumns(63).DataBodyRange.Value
Dim sc_req() As Variant
sc_req = t.ListColumns(64).DataBodyRange.Value
Dim x_req() As Variant
x_req = t.ListColumns(65).DataBodyRange.Value
Dim bo() As Variant
bo = t.ListColumns(69).DataBodyRange.Value
Dim ans() As Variant
ans = t.ListColumns(70).DataBodyRange.Value
Dim reqkind() As Variant
reqkind = t.ListColumns(2).DataBodyRange.Value
For i = 2 To n Step 1
If rel(i, 1) = 0 Or ans(i, 1) <> 0 Then
GoTo Nexti
ElseIf ans(i, 1) = 0 And rel(i, 1) = 1 Then
While t_req(i, 1) > 0
For j = i To n - 1
If dc(i, 1) > 0 Then
If reqkind(i, 1) = "" Then
ans(i, 1) = "YES"
t_req(i, 1) = t_req(i, 1) - 1
sc_req(i, 1) = sc_req(i, 1) - 1
ElseIf sc_req(i, 1) <= 0 Then
ans(i, 1) = "YES"
t_req(i, 1) = t_req(i, 1) - 1
x_req(i, 1) = x_req(i, 1) - 1
Else: GoTo Nextj
End If
ElseIf reqkind(i, 1) = "" Then
If bo(i, 1) > 0 Then
ans(i, 1) = "YES"
t_req(i, 1) = t_req(i, 1) - 1
bo(i, 1) = bo(i, 1) - 1
Else
ans(i, 1) = "NO"
t_req(i, 1) = t_req(i, 1) - 1
End If
Else
ans(i, 1) = "NO"
t_req(i, 1) = t_req(i, 1) - 1
End If
Nextj:
Next j
Wend
End If
Nexti:
Next i```
Related
I have two Strings in different cells for example
ADSGPINDTDANPR
RGTELDDGIQADSGPINDTDANPRY VPGYY ESQSDDPHFHEK
Also character sequences can have gaps for similar sequences like RGX in following example
LADNS TFDDDLDDLTPSKMKPANFKGD
RSLA FDDDLDDLTPSRGXKMKPANFKGDYG
What I want to do is Highlight both the sequences as shown in above example in Bold And Italic but in color using VBA code.
Edit :
As per the first answer of #milo5m
Sequence is highlighted as follows
MNTVEEVDSEEDEESAP GSV GSMPSTGSAKYYTNRVPFDMIA
EQPMNTVEEVDSEEDEESAPA
But desired result should be like this:
MNTVEEVDSEEDEESAP GSV GSMPSTGSAKYYTNRVPFDMIA
EQPMNTVEEVDSEEDEESAPA
Edit 2 :
Currently answer of #milo5m highlights single characters as shown in below examples
SKPERYSG
TAPGEQAQD
SKPERYSG
AQD QKLAPSE
In above examples no sequence should have been highlighted...
In other words, It should only highlight the Single characters when there is space before the Character, otherwise it should not highlight single characters between sequences.
It's really nice that we have these two as a reference
https://www.sciencedirect.com/science/article/pii/S0890540114000765
https://en.wikipedia.org/wiki/Longest_common_subsequence_problem
Here is the main function which is returning all subsequences forming the LCS (if you join all the keys you get the LCS in reverse subsequence form).
Function returns a dictionary where keys are subsequences, and values are arrays with 2 elements (position of subsequence in seqA and position of subsequence in seqB).
Function GetLCSSubSequenceDict(seqA As String, seqB As String) As Object
Set GetLCSSubSequenceDict = Nothing
Dim i As Long, n As Long
n = Len(seqA)
If n = 0 Then: Exit Function
Dim j As Long, m As Long
m = Len(seqB)
If m = 0 Then: Exit Function
Dim T() As Long
ReDim T(0 To n, 0 To m)
'Building up table
For i = 1 To n
For j = 1 To m
If Mid$(seqA, i, 1) <> Mid$(seqB, j, 1) Then
'bitwise max
T(i, j) = T(i - 1, j) Xor ((T(i - 1, j) Xor T(i, j - 1)) And --(T(i - 1, j) < T(i, j - 1)))
Else
T(i, j) = T(i - 1, j - 1) + 1
End If
Next j
Next i
Dim subseqKey As String
Dim subseqABDict As Object
Set subseqABDict = CreateObject("Scripting.Dictionary")
'Backtracking and building up dict of subsequences
'key = subsequence
'value = array(starting pos of the key in seqA,starting pos of the key in seqB)
i = n
j = m
Do While (i > 0 And j > 0)
If Not Mid$(seqA, i, 1) <> Mid$(seqB, j, 1) Then
subseqKey = Mid$(seqA, i, 1) & subseqKey
i = i - 1
j = j - 1
ElseIf T(i - 1, j) > T(i, j - 1) Then
If subseqKey <> vbNullString Then
subseqABDict(subseqKey) = Array(i + 1, j + 1)
subseqKey = vbNullString
End If
i = i - 1
Else
If subseqKey <> vbNullString Then
subseqABDict(subseqKey) = Array(i + 1, j + 1)
subseqKey = vbNullString
End If
j = j - 1
End If
Loop
If subseqKey <> vbNullString Then
subseqABDict(subseqKey) = Array(i + 1, j + 1)
End If
Set GetLCSSubSequenceDict = subseqABDict
Set subseqABDict = Nothing
End Function
Time complexity of the function is O ( Len(seqA) * Len(seqB) ), for those who are interested.
Following is a show case of setting font properties on 2 ranges seqA and seqB.
Sub test()
Dim seqA As Range
Dim seqB As Range
Set seqA = Range("A4")
Set seqB = Range("B4")
Dim fontColor As Long
fontColor = RGB(84, 84, 84)
Dim subseqKey As Variant
Dim lcsSubSequenceDict As Object
Set lcsSubSequenceDict = GetLCSSubSequenceDict(seqA.Value2, seqB.Value2)
'gives subsequences in reversed order, since we used backtracking
'MsgBox Join(lcsSubSequenceDict.keys())
If lcsSubSequenceDict Is Nothing Then: Exit Sub
For Each subseqKey In lcsSubSequenceDict
With seqA.Characters(lcsSubSequenceDict(subseqKey)(0), Len(subseqKey)).Font
.color = fontColor
.Bold = True
.Italic = True
End With
With seqB.Characters(lcsSubSequenceDict(subseqKey)(1), Len(subseqKey)).Font
.color = fontColor
.Bold = True
.Italic = True
End With
Next subseqKey
Set lcsSubSequenceDict = Nothing
Set seqA = Nothing
Set seqB = Nothing
End Sub
Edit:
(1) Fixed - Backtracking showing positions in sequences further to the right for multiple candidates
(2) Main Function returns Collection now (was returning Dictionary)
Function GetLCSSubSequenceCollection(seqA As String, seqB As String) As Collection
Set GetLCSSubSequenceCollection = Nothing
Dim i As Long, n As Long
n = Len(seqA)
If n = 0 Then: Exit Function
Dim j As Long, m As Long
m = Len(seqB)
If m = 0 Then: Exit Function
Dim T() As Long
ReDim T(0 To n, 0 To m)
'Building up table
For i = 1 To n
For j = 1 To m
If Mid$(seqA, i, 1) <> Mid$(seqB, j, 1) Then
'bitwise max
T(i, j) = T(i - 1, j) Xor ((T(i - 1, j) Xor T(i, j - 1)) And --(T(i - 1, j) < T(i, j - 1)))
Else
T(i, j) = T(i - 1, j - 1) + 1
End If
Next j
Next i
Dim subseqKey As String
Dim subseqABCollection As Collection
Set subseqABCollection = New Collection
'Backtracking and building up collection of subsequences
'value = array(subsequence, starting pos of the key in seqA,starting pos of the key in seqB)
i = n
j = m
Do While (i > 0 And j > 0)
If Not Mid$(seqA, i, 1) <> Mid$(seqB, j, 1) Then
subseqKey = Mid$(seqA, i, 1) & subseqKey
i = i - 1
j = j - 1
ElseIf T(i - 1, j) > T(i, j - 1) Then
If subseqKey <> vbNullString Then
subseqABCollection.Add Array(subseqKey, i + 1, j + 1)
subseqKey = vbNullString
End If
i = i - 1
Else
If subseqKey <> vbNullString Then
subseqABCollection.Add Array(subseqKey, i + 1, j + 1)
subseqKey = vbNullString
End If
j = j - 1
End If
Loop
If subseqKey <> vbNullString Then
subseqABCollection.Add Array(subseqKey, i + 1, j + 1)
End If
If subseqABCollection.Count = 0 Then: Exit Function
'fix backtracking showing positions in arrays further to the right for multiple candidates
'using inStr to chack starting from prev position etc
Dim prevSubseqPosA As Long, prevSubseqPosB As Long
prevSubseqPosA = 1
prevSubseqPosB = 1
Set GetLCSSubSequenceCollection = New Collection
For i = subseqABCollection.Count To 1 Step -1
subseqKey = subseqABCollection.Item(i)(0)
prevSubseqPosA = InStr(prevSubseqPosA, seqA, subseqKey)
prevSubseqPosB = InStr(prevSubseqPosB, seqB, subseqKey)
GetLCSSubSequenceCollection.Add Array(subseqKey, prevSubseqPosA, prevSubseqPosB)
prevSubseqPosA = prevSubseqPosA + Len(subseqKey)
prevSubseqPosB = prevSubseqPosB + Len(subseqKey)
Next
Set subseqABCollection = Nothing
End Function
Sub testCollection()
Dim lcs As String
Dim seqA As Range
Dim seqB As Range
Set seqA = Range("A4")
Set seqB = Range("B4")
Dim fontColor As Long
fontColor = RGB(84, 84, 84)
Dim lcsSubSequenceItem As Variant
Dim lcsSubSequenceCollection As Collection
Set lcsSubSequenceCollection = GetLCSSubSequenceCollection(seqA.Value2, seqB.Value2)
If lcsSubSequenceCollection Is Nothing Then: Exit Sub
For Each lcsSubSequenceItem In lcsSubSequenceCollection
With seqA.Characters(lcsSubSequenceItem(1), Len(lcsSubSequenceItem(0))).Font
.color = fontColor
.Bold = True
.Italic = True
End With
With seqB.Characters(lcsSubSequenceItem(2), Len(lcsSubSequenceItem(0))).Font
.color = fontColor
.Bold = True
.Italic = True
End With
lcs = lcs & lcsSubSequenceItem(0)
Next lcsSubSequenceItem
MsgBox lcs & " [ LEN = " & Len(lcs) & " ]"
Set lcsSubSequenceCollection = Nothing
Set seqA = Nothing
Set seqB = Nothing
End Sub
Tough challenge, and I'm not sure if it's that feasible with Excel alone. Assuming that:
You will not allow the 1st entry to have gaps;
You allow for 0+ gaps in between in the 2nd entry;
You are looking for the longest match between both entries;
You have ms365;
You may try the below answer that I based of on a formula first, see the below screenshot:
Formula in C1:
=LET(x,SCAN(,UNIQUE(TOCOL(MID(A1,SEQUENCE(LEN(A1)),SEQUENCE(1,LEN(A1))))),LAMBDA(a,b,TEXTJOIN("*",,MID(b,SEQUENCE(1,LEN(b)),1)))),y,SEARCH(x,B1),z,SORTBY(HSTACK(x,y),LEN(x)*(ISNUMBER(y)),-1),SUBSTITUTE(TAKE(FILTER(z,ISNUMBER(INDEX(z,,2))),1,1),"*",))
The above will identify the longest substring that has a match with 0+ gaps in between. This is going to be the input to the below macro:
Sub Test()
Dim ws As Worksheet, lr As Long, x As Long, y As Long, z As Long, a As Long, arr As Variant, s As String
Set ws = ThisWorkbook.Worksheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
arr = ws.Range("A1:C" & lr)
For x = LBound(arr) To UBound(arr)
s = arr(x, 3)
'Format column A:A
ws.Cells(x, 1).Characters(InStr(1, ws.Cells(x, 1).Value, s), Len(s)).Font.Bold = True
ws.Cells(x, 1).Characters(InStr(1, ws.Cells(x, 1).Value, s), Len(s)).Font.Italic = True
'Format column B:B
z = 0
For y = 1 To Len(s)
z = InStr(z + 1, ws.Cells(x, 2).Value, Mid(s, y, 1))
ws.Cells(x, 2).Characters(z, 1).Font.Bold = True
ws.Cells(x, 2).Characters(z, 1).Font.Italic = True
Next
Next
End Sub
The results look like:
I have a list of data displayed on a listbox, after clicking on a button the list appears on my userform.
I have dates on column 2 of my list, I want to do a descending sorting.
I have the code bellow but it's not working, am I wrong ?
fin_col_Form_Init = Ws.Cells(6, 256).End(xlToLeft).Column
UF_Profil_Edit1.ListBox_Form_Init.ColumnCount = 2
UF_Profil_Edit1.ListBox_Form_Init.ColumnWidths = "300;100"
fin_col_Form_Init = Ws.Cells(6, 256).End(xlToLeft).Column
UF_Profil_Edit1.ListBox_Form_Init.ColumnCount = 2
UF_Profil_Edit1.ListBox_Form_Init.ColumnWidths = "300;100"
For i = 2 To fin_col_Form_Init
UF_Profil_Edit1.ListBox_Form_Init.AddItem Ws.Cells(6, i)
UF_Profil_Edit1.ListBox_Form_Init.List(UF_Profil_Edit1.ListBox_Form_Init.ListCount - 1, 1) = Ws.Cells(7, i)
Next i
Dim y, x As Integer
Dim MyList As Variant
With UF_Profil_Edit1.ListBox_Form_Init
For y = 0 To .ListCount - 1
For x = y To .ListCount - 1
If CDate(.List(x, 1)) > CDate(.List(y, 1)) Then
For c = 0 To 2
MyList = .List(x, c)
.List(x, c) = .List(y, c)
.List(y, c) = MyList
Next c
End If
Next x
.List(y, 2) = Format(.List(y, 2), "####.00")
Next y
End With
Try the next code, please:
Sub testSortListBox()
Dim i As Long, j As Long, sTemp As Date, sTemp2 As String, SortList As Variant
UF_Profil_Edit1.ListBox_Form_Init.ColumnCount = 2
UF_Profil_Edit1.ListBox_Form_Init.ColumnWidths = "300;100"
'Store the list in an array to be sorted:
SortList = UF_Profil_Edit1.ListBox_Form_Init.List
'Sort the array on the second column
For i = LBound(SortList, 1) To UBound(SortList, 1) - 1
For j = i + 1 To UBound(SortList, 1)
If CDate(SortList(i, 1)) < CDate(SortList(j, 1)) Then
'Swap the second value
sTemp = SortList(i, 1)
SortList(i, 1) = SortList(j, 1)
SortList(j, 1) = sTemp
'Swap the first value
sTemp2 = SortList(i, 0)
SortList(i, 0) = SortList(j, 0)
SortList(j, 0) = sTemp2
End If
Next j
Next i
'Remove the contents of the listbox:
UF_Profil_Edit1.ListBox_Form_Init.Clear
'Load the sorted array in the list box:
UF_Profil_Edit1.ListBox_Form_Init.List = SortList
End Sub
But, please note: The list box in discussion must not be linked to a range (not being load by its RowSource property...
I read data I stored in a worksheet table into a VBA array. I need the first "column" of this array to be in lowercase. (The purpose of this array is to allow quicker calculations with the data contained in the table without referring to the table itself.)
I do this with the "LCase()" function, and I used the "Debug.print()" function to verify that they are being stored as lowercase.
However, later on in the code when I refer to this array, the values have reverted to their original case. I haven't added/edited the array beyond the point that I read the table data into it.
Simplified code:
Dim wb as Workbook
Dim ws as Worksheet
Dim tbl_Data as ListObject
Dim arr(1 to 10, 1 to 2) as Variant
Dim i as Integer
Dim calcValue as Single
Dim stringMatch as String
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet 1")
Set tbl_Data = ws.ListObjects("Table1")
For i = 1 to tbl_Data.ListRows.Count
arr(i, 1) = LCase(tbl_Data.DataBodyRange(i, 1))
arr(i, 2) = tbl_Data.DataBodyRange(i, 2))
Debug.Print(arr(i, 1)) 'Returns lowercase values normally
Next i
'---Insert calculations here
'- Returns calcValue (ex. calcValue = 10.12)
For i = 1 to UBound(arr, 1)
If calcValue = arr(i, 2) Then
Debug.Print(arr(i, 1)) 'Returns strings with original case values
stringMatch = arr(i, 1)
End If
Next i
I do not see an issue with the code that would cause the values stored to revert back to the original.
The original code. I hope that it makes sense, without the context of the data itself.
Option Explicit
Sub updateInventory()
Dim wb As Workbook
Dim sh_NewInventory As Worksheet
Dim sh_MasterInventory As Worksheet
Dim tbl_MasterInventory As ListObject
Dim cell_NewIngredient As Range
Dim arr_NewIngredients(1 To 30, 1 To 4) As Variant
Dim arr_MasterInventory(1 To 60, 1 To 6) As Variant
Dim i As Integer, j As Integer
Dim bool_isCellBlank As Boolean
Dim bool_isIngredientMatch As Boolean
Set wb = ThisWorkbook
Set sh_NewInventory = wb.Worksheets("Update Inventory")
Set sh_MasterInventory = wb.Worksheets("Food Inventory")
Set tbl_MasterInventory = sh_MasterInventory.ListObjects("MasterInventory")
Set cell_NewIngredient = sh_NewInventory.Range("B3")
bool_isCellBlank = False
bool_isIngredientMatch = False
i = 1
Do While Not bool_isCellBlank
arr_NewIngredients(i, 1) = LCase(cell_NewIngredient)
arr_NewIngredients(i, 2) = LCase(cell_NewIngredient.Offset(0, 1))
arr_NewIngredients(i, 3) = cell_NewIngredient.Offset(0, 2)
arr_NewIngredients(i, 4) = cell_NewIngredient.Offset(0, 3)
i = i + 1
Set cell_NewIngredient = cell_NewIngredient.Offset(1, 0)
bool_isCellBlank = (cell_NewIngredient = "")
Loop
For i = 1 To tbl_MasterInventory.ListRows.Count
arr_MasterInventory(i, 1) = LCase(tbl_MasterInventory.DataBodyRange(i, 1))
arr_MasterInventory(i, 2) = LCase(tbl_MasterInventory.DataBodyRange(i, 2))
For j = 1 To tbl_MasterInventory.ListColumns.Count - 2
arr_MasterInventory(i, j) = tbl_MasterInventory.DataBodyRange(i, j)
Next j
Next i
For i = 1 To UBound(arr_NewIngredients, 1)
j = 0
bool_isIngredientMatch = False
Do While Not bool_isIngredientMatch
j = j + 1
If arr_NewIngredients(i, 1) = LCase(arr_MasterInventory(j, 1)) Then
bool_isIngredientMatch = True
Debug.Print (arr_NewIngredients(i, 1) & " : " & arr_MasterInventory(j, 1))
End If
Loop
Next i
End Sub
RESULTS: Immediate Window
I figured it out!
See the following code (reading data into the array):
For i = 1 To tbl_MasterInventory.ListRows.Count
arr_MasterInventory(i, 1) = LCase(tbl_MasterInventory.DataBodyRange(i, 1))
arr_MasterInventory(i, 2) = LCase(tbl_MasterInventory.DataBodyRange(i, 2))
For j = 1 To tbl_MasterInventory.ListColumns.Count - 2
arr_MasterInventory(i, j) = tbl_MasterInventory.DataBodyRange(i, j)
Next j
Next i
I made a mistake in the loop using the "j" index. By starting at "j=1", I was replacing what I had done prior to the "j" For loop, which was what caused the data to be re-entered as the original version.
I feel real dumb for making the mistake, but I'm glad y'all looked at it for me! Thanks again!
I have an excel table where there are part codes in a column and for every part code, there are 3-4 subsections (1100-1400) with information which I need to attach to the part code in a column view.
The number of created rows depends on if there is data entered into subsection 1400. 1100-1300 has always information and needs to be converted into a table.
I don't even know from where to start so currently I have no code to show
I added a picture of how the data is represented and what the result should look like:
You could do it like that
Option Explicit
Sub TransformA()
Dim rg As Range
Dim lastRow As Long, lineNo As Long, i As Long, j As Long
Dim shInput As Worksheet, shResult As Worksheet
Dim vDat As Variant, resDat As Variant
Dim subSection As String
' Make sure you run the code with the data in the Activesheet
Set shInput = ActiveSheet
' And you have data which starts in row 4 with the heading in row 3
' otherwise adjust accordingly
lastRow = shInput.Range("A4").End(xlDown).Row
Set rg = shInput.Range("A4:I" & lastRow)
vDat = rg
ReDim resDat(1 To UBound(vDat, 1) * 4, 1 To 4)
lineNo = 1
For j = 1 To UBound(vDat, 1)
For i = 0 To 2
Select Case i
Case 0: subSection = "1100"
Case 1: subSection = "1200"
Case 2: subSection = "1300"
End Select
resDat(lineNo + i, 1) = vDat(j, 1)
resDat(lineNo + i, 2) = subSection
resDat(lineNo + i, 3) = vDat(j, 2 + 2 * i)
resDat(lineNo + i, 4) = vDat(j, 3 + 2 * i)
Next
i = 3
subSection = "1400"
If Len(vDat(j, 2 + 2 * i)) = 0 And Len(vDat(j, 3 + 2 * i)) = 0 Then
lineNo = lineNo + 3
Else
resDat(lineNo + i, 1) = vDat(j, 1)
resDat(lineNo + i, 2) = subSection
resDat(lineNo + i, 3) = vDat(j, 2 + 2 * i)
resDat(lineNo + i, 4) = vDat(j, 3 + 2 * i)
lineNo = lineNo + 4
End If
Next
' Output the result to a new sheet
Set shResult = Sheets.Add
With shResult
.Cells(1, 1).Value = "Part Code"
.Cells(1, 2).Value = "Subsection"
.Cells(1, 3).Value = "Time"
.Cells(1, 4).Value = "Text"
End With
shResult.Range("A2").Resize(UBound(resDat, 1), 4) = resDat
End Sub
thanks in advance for taking the time to help. I have built a Do While loop in VBA that for some reason breaks when j = 1. I have in cells C3:C7 these values: 13,14,14,13,14.
Here's the short script:
Dim i, j, n As Integer
Dim List(0) As Integer
i = o
j = 0
n = 0
Do While Cells(i + 3, 3) <> ""
If Cells(i + 3, 3) > 13 Then
List(j) = i + 3
j = j + 1
Cells(i + 3, 4) = "Noted"
i = i + 1
ElseIf Cells(i + 3, 3) = 13 Then
Cells(i + 3, 4) = "Skipped"
i = i + 1
Else
i = i + 1
End If
Loop
For n = j To n = 0
Rows(List(n)).Delete
Next
Thanks again!
Your intent is sound, but there are quite a few errors. See commented code below for details
Sub Demo()
' ~~ must explicitly type each variable. Use Long
Dim i As Long, j As Long, n As Long
Dim List() As Long '<~~ dynamic array
i = 3 '<~~ eliminate the klunky +3
j = 0
n = 0
ReDim List(0 To 0) '<~~ initialise dynamic array
Do While Cells(i, 3) <> vbNullString
If Cells(i, 3) > 13 Then
ReDim Preserve List(0 To j) '<~~ resize array
List(j) = i
j = j + 1
Cells(i, 4) = "Noted"
ElseIf Cells(i, 3) = 13 Then
Cells(i, 4) = "Skipped"
End If
i = i + 1 '<~~ simplify, its called in each if case anyway
Loop
' j will end up 1 greater than size of array
If j > 0 Then '<~~ only execute if we found some rows to delete
For n = j - 1 To 0 Step -1 '<~~ For loop syntax
Rows(List(n)).Delete
Next
End If
End Sub