Solved: Understand and Modify Code

[fredlo2010]

Hello guys,

I have this code that the experts in this forum helped me with. Here is the link http://www.vbaexpress.com/forum/showthread.php?t=42325

Basically the code goes through column B and if there is any blank cells then the range A:B for that row will be deleted as long as the contents in cell A are not "Cookies", "Salt", ""

The problem is that this code goes way beyond my limited VBA knowledge. I cannot modify it I can barely read it.
I want to modify so if there is more than two consecutive "Cookies", "Salt", "" then delete that range too. Sometimes I end up with data looking like this:


Cookies
Cookies
Cookies
Cookies
4525
Salt
Cookies
425
55886


Also i would like to see if I can extend my search to a different cell range. Look for empty cells in column B and C, if found the delete the range A:C for that specific row.

Here is the code I am using.

Sub test()
Dim a, b(), i As Long, ii As Long, n As Long, flg As Boolean
With Range("a2", Range("a" & Rows.Count).End(xlUp)).Resize(, 2)
a = .Value
Redim b(1 To UBound(a, 1), 1 To UBound(a, 2))
For i = 1 To UBound(a, 1)
If a(i, 2) = "" Then
Select Case a(i, 1)
Case "Cookies", "Salt", ""
n = n + 1
flg = True
Case Else
End Select
Else
n = n + 1: flg = True
End If
If flg Then
For ii = 1 To UBound(a, 2)
b(n, ii) = a(i, ii)
Next
End If
flg = False
Next
.Value = b
End With
End Sub

Thanks a lot for your help guys

[JapanDave]

With respects to the original code provider Jindon.

Try this,

Sub test()
Dim a, b(), i As Long, ii As Long, n As Long, flg As Boolean
With Range("a2", Range("a" & Rows.Count).End(xlUp)).Resize(, 2)
a = .Value
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
For i = 1 To UBound(a, 1)
If a(i, 2) = "" Then
If i <> 1 Then
If a(i, 2) = a(i - 1, 2) Then
Select Case a(i, 1)
Case "Cookies", "Salt", ""
n = n + 1
flg = True
Case Else
End Select
Else
Select Case a(i, 1)
Case "Cookies", "Salt", ""
n = n + 1
flg = True
Case Else
End Select
End If
n = n + 1: flg = True
End If
Else
n = n + 1: flg = True
End If
If flg Then
For ii = 1 To UBound(a, 2)
b(n, ii) = a(i, ii)
Next
End If
flg = False
Next
.Value = b
End With
End Sub

[fredlo2010]

Hi JapanDave,

I am getting a subscript out of range error.

Any ideas?

[JapanDave]

Does this web site allow uploading workbooks? It is pretty hard to tell where and what is going wrong. But if that error is occurring I would say it has something to do with the array.

Can you post a sample workbook?

[fredlo2010]

HI JapanDave.

I made a very simple copy of the workbook. Nothing fancy my original code works with it.

I get the error in this line btw

b(n, ii) = a(i, ii)

8356

[fredlo2010]

Can someone help me with this? I cannot figure it out. :(

[Aussiebear]

Does this web site allow uploading workbooks?


Click on Go Advanced, then scroll down to Manage Attachments and follow the prompts from there.

[JapanDave]

I posted in the wrong thread,

http://www.vbaexpress.com/forum/showpost.php?p=271492&postcount=26

Try this,

Sub dave()
Dim cl(), lr, j, jj, val()
Application.ScreenUpdating = 0
lr = Cells(Rows.Count, 1).End(xlUp).Row
ReDim cl(1 To 2, 1 To lr)
ReDim val(1 To 2, 1 To lr)
x = 1
For i = 2 To lr
j = Cells(i, 1).Value
jj = Cells(i, 2).Value
If j = "Cookies" Or j = "Salt" Or jj <> "" Then
val(1, x + 1) = Cells(i + 1, 1).Value
If val(1, x + 1) <> "Cookies" Then
cl(1, x) = j
cl(2, x) = jj
x = x + 1
End If
End If
Next i
ReDim Preserve cl(1 To 2, 1 To x - 1)
Cells(2, 1).Resize(lr, 2).ClearContents
Cells(2, 1).Resize(x - 1, 2).Value = Application.Transpose(cl)
ActiveSheet.ListObjects("Table1").Resize Range("$A$1:$B$" & x)
Application.ScreenUpdating = 1
End Sub