Need a macro that follows IF statements?

[Katie620]

Hi!

I'm trying to write a macro that uses IF statements to solve the problem where text can't overflow into adjacent columns if there is a formula in the next columns. So I'm just trying to have a description above each block of time, I can't use formulas for this because of the reason I just mentioned.

I'm trying to make this car repair schedule:

ibb.co/jRZDFF

Look like this:

ibb.co/dH3vUa

The example excel file is here::

ufile.io/m8ndb

The yellow cells in column B are the rows where I need a macro. But note that I have made everything static, there are supposed to be formulas in the other two lines (rows 13 and 15, rows 23 and 25, etc).

I'm trying to have above each colored block of time, a description of the work below, as long as the block is 30 or more days long. The description (where the macro will pull the data from) is simply in the cell above, and the block of time is in the cell below, with the macro line in between both.

I think the logic I need is:

Run the macro on specific rows (14,24,34,44,54,64,74,84,94,114) beginning at column F. An ending column isn't necessary but if it must be specified, column NG is the last column.

For every cell on these rows within that range:

If the cell one row down on the same column is blank (FYI it is not technically blank but is made blank by a formula) OR if the cell one row down on the same column equals the cell one row down and one column to the LEFT, then clear that cell.

If not, then:


Make the cell equal the cell directly above (which will have the description).

One last condition: The cell should only equal the cell directly above if the block of time below repeats for 30 or more days (which are the same as columns in my spreadsheet). If you look at my images this just makes it so that a description doesn't appear above the block of time if the block of time is too short to really show anything.



I think the above will give me what I have in my second image. Does that make sense? I've tried writing this using some if statements I've found on the internet and using the macro recorder for the other parts but I can't get close to anything workable.

Is this something that a macro can even do??:wot

Thanks!!

[mdmackillop]

Please post a workbook with your data and desired result. Go Advanced/Manage Attachments

[Katie620]

Done! Attached the images too just in case. On the left is before running macro, on the right is a sample of what I'm looking for after running macro, where the yellow highlighted rows are the rows on which the macro should run.

[mdmackillop]

Not far away but issues on Row 85. Away for a while

Sub Test()
Dim i, x, arr()
Dim rw
Dim cel As Range


For Each cel In Range("B:B").SpecialCells(2)
If cel.Interior.ColorIndex = 6 Then _
cel.Offset(, 4).Resize(, 370).ClearContents
Next cel


For Each cel In Range("B:B").SpecialCells(2)
If cel.Interior.ColorIndex = 6 Then
cel.Offset(, 4).Resize(, 370).ClearContents
'Range("NI1").Resize(20).ClearContents
ReDim arr(50): x = 0
rw = cel.Row + 1
For i = 5 To 371
If Cells(rw, i) <> Cells(rw, i + 1) Then
If Cells(rw, i) = "" Then
arr(x) = i + 1
x = x + 1
Else
arr(x) = i
arr(x + 1) = i + 1
x = x + 1
End If
'Cells(x, 373) = arr(x - 1)
End If
Next i
ReDim Preserve arr(x - 1)
For i = 0 To UBound(arr) - 1 Step 2
Cells(cel.Row, arr(i)).Select
If arr(i + 1) - arr(i) > 30 Then
With Cells(cel.Row, arr(i) + 1)
'.Select
.FormulaR1C1 = "=R[-1]C[]"
.HorizontalAlignment = xlLeft
End With
End If
Next
End If
Next cel
End Sub

[Katie620]

Wow, this almost works perfectly, thank you so much! :) I see three issues:

1.) As you mentioned, row 84 isn't working correctly. But also row 94 isn't working correctly. This might be because these two rows/bays have multiple lines that are colored (for example expand the grouping and look at rows 95 through 108 and also 86 through 92). I didn't mention this because I only need descriptions above the top (ungrouped) row in each bay. These other rows need to be there (grouped/hidden) but don't need descriptions. Could that be what is causing the problem? FYI with real data this could happen to any of the bays, not just bay 8 and bay 9. Understanding that part of the code leads me to question 2...

2.) I've just begun analyzing this code but I can't yet find out how it's choosing which rows to run the macro on. I see that it's running on columns 5 through 371, but how/where is it specified which rows it's run on? My actual file with real data looks very similar to this but there won't always be the same number of bays and there could be more bays, so I need to figure out how to change which rows the code runs on?

3.) I only bring this up in case you happen to have any advice or ideas: My next step was to merge and wrap text for each description. It would be merged and wrapped until the row below changes values (meaning that it either changes from one customer to another or changes from a customer to blank). Please see image for how this would look. Just in case you have an idea of how to implement this but its not as essential as getting all the bays to work. I would either then manually widen each description row to something like a height of 40 or the macro would do it.

I very much appreciate your help so far!

[mdmackillop]

The code runs on the yellow cells

For Each cel In Range("B:B").SpecialCells(2)
If cel.Interior.ColorIndex = 6 Then

[mdmackillop]

Hi Katie,
Please only quote text relevant to your question, not whole posts.

Sub test() Dim i, x, arr()
Dim rw
Dim cel As Range


For Each cel In Range("B:B").SpecialCells(2)
If cel.Interior.ColorIndex = 6 Then _
cel.Offset(, 4).Resize(, 370).ClearContents
Next cel


For Each cel In Range("B:B").SpecialCells(2)
If cel.Interior.ColorIndex = 6 Then
cel.Offset(, 4).Resize(, 370).ClearContents
'Range("NI1").Resize(20).ClearContents
ReDim arr(50): x = 0
rw = cel.Row + 1
For i = 5 To 371
If Cells(rw, i) <> Cells(rw, i + 1) Then
If Cells(rw, i) = "" And Cells(rw, i + 1) <> "" Then
arr(x) = i + 1
'Cells(x + 1, 373) = arr(x)
x = x + 1
End If
If Cells(rw, i) <> "" And Cells(rw, i + 1) = "" Then
arr(x) = i
'Cells(x + 1, 373) = arr(x)
x = x + 1
End If
If Cells(rw, i) <> "" And Cells(rw, i + 1) <> "" Then
arr(x) = i
'Cells(x + 1, 373) = arr(x)
x = x + 1
arr(x) = i + 1
'Cells(x + 1, 373) = arr(x)
x = x + 1
End If
End If
Next i
ReDim Preserve arr(x - 1)
For i = 0 To UBound(arr) - 1 Step 2
Cells(cel.Row, arr(i)).Select
If arr(i + 1) - arr(i) > 30 Then
With Cells(cel.Row, arr(i))
.FormulaR1C1 = "=R[-1]C[]"
.HorizontalAlignment = xlLeft
End With
'This can be deleted @@@@@@@@@@@@@@
Else
With Cells(cel.Row, arr(i))
.Value = arr(i + 1) - arr(i) + 1 & " days"
.HorizontalAlignment = xlLeft
End With
'to here @@@@@@@@@@@@@@@@@@@
End If
Next
End If
Next cel
End Sub

[Katie620]

You got it, thank you so much!!!!!

I have to ask, would implementing the below be difficult?


3.) I only bring this up in case you happen to have any advice or ideas: My next step was to merge and wrap text for each description. It would be merged and wrapped until the row below changes values (meaning that it either changes from one customer to another or changes from a customer to blank). Please see image for how this would look. Just in case you have an idea of how to implement this but its not as essential as getting all the bays to work. I would either then manually widen each description row to something like a height of 40 or the macro would do it.

[mdmackillop]

Sub test1()
Dim i, x, arr()
Dim rw
Dim cel As Range
Dim Wdth As Long


For Each cel In Range("B:B").SpecialCells(2)
If cel.Interior.ColorIndex = 6 Then _
cel.Offset(, 4).Resize(, 370).ClearContents
Next cel


For Each cel In Range("B:B").SpecialCells(2)
If cel.Interior.ColorIndex = 6 Then
cel.Offset(, 4).Resize(, 370).ClearContents
'Range("NI1").Resize(20).ClearContents
ReDim arr(50): x = 0
rw = cel.Row + 1
For i = 5 To 371
If Cells(rw, i) <> Cells(rw, i + 1) Then
If Cells(rw, i) = "" And Cells(rw, i + 1) <> "" Then
arr(x) = i + 1
'Cells(x + 1, 373) = arr(x)
x = x + 1
End If
If Cells(rw, i) <> "" And Cells(rw, i + 1) = "" Then
arr(x) = i
'Cells(x + 1, 373) = arr(x)
x = x + 1
End If
If Cells(rw, i) <> "" And Cells(rw, i + 1) <> "" Then
arr(x) = i
'Cells(x + 1, 373) = arr(x)
x = x + 1
arr(x) = i + 1
'Cells(x + 1, 373) = arr(x)
x = x + 1
End If
End If
Next i
ReDim Preserve arr(x - 1)
For i = 0 To UBound(arr) - 1 Step 2
Wdth = arr(i + 1) - arr(i)
If Wdth >= 30 Then
Cells(cel.Row, arr(i)).FormulaR1C1 = "=R[-1]C[]"
With Cells(cel.Row, arr(i)).Resize(, Wdth)
.HorizontalAlignment = xlCenterAcrossSelection
.WrapText = True
End With
'This can be deleted @@@@@@@@@@@@@@
Else
With Cells(cel.Row, arr(i))
.Value = arr(i + 1) - arr(i) + 1 & " days"
.HorizontalAlignment = xlLeft
End With
'to here @@@@@@@@@@@@@@@@@@@
End If
Next
End If
Next cel
End Sub

[Katie620]

Amazing, and amazing what can be done with macros!!! Thank you so much!!!!! I still have a couple tiny changes to make (make it not use color recognition for B:B, etc) but I can figure out how to do that myself, I don't want to bother you anymore!

Thank you again, I'll mark this as solved :)

[mdmackillop]

Happy to help. Please post if you have other queries.

[Katie620]

Hi mdmackillop!!!

After extensive testing, I found two problems with the code (not to say the code isn't great and doesn't work great otherwise :))

I know this thread is marked as solved but if you happen to have any ideas:

1.) If there is an empty bay, the code breaks with an error. In other words, if there is a cell in column B that is yellow, but the columns that the macro looks at in that same row is totally empty, it breaks.

2.) I don't really understand this one: If the row heights are manipulated to be larger or smaller the part of the code that resizes the row height doesn't work.

I've attached a macro free workbook to show you what I mean. For 1.) See the tab "with empty bay (bay 5)" and for 2.) see the tab "with row heights messed up" (I made all the rows a smaller height).

I'm running your most recent code on them:


Sub test1() Dim i, x, arr()
Dim rw
Dim cel As Range
Dim Wdth As Long


For Each cel In Range("B:B").SpecialCells(2)
If cel.Interior.ColorIndex = 6 Then _
cel.Offset(, 4).Resize(, 370).ClearContents
Next cel


For Each cel In Range("B:B").SpecialCells(2)
If cel.Interior.ColorIndex = 6 Then
cel.Offset(, 4).Resize(, 370).ClearContents
'Range("NI1").Resize(20).ClearContents
ReDim arr(50): x = 0
rw = cel.Row + 1
For i = 5 To 371
If Cells(rw, i) <> Cells(rw, i + 1) Then
If Cells(rw, i) = "" And Cells(rw, i + 1) <> "" Then
arr(x) = i + 1
'Cells(x + 1, 373) = arr(x)
x = x + 1
End If
If Cells(rw, i) <> "" And Cells(rw, i + 1) = "" Then
arr(x) = i
'Cells(x + 1, 373) = arr(x)
x = x + 1
End If
If Cells(rw, i) <> "" And Cells(rw, i + 1) <> "" Then
arr(x) = i
'Cells(x + 1, 373) = arr(x)
x = x + 1
arr(x) = i + 1
'Cells(x + 1, 373) = arr(x)
x = x + 1
End If
End If
Next i
ReDim Preserve arr(x - 1)
For i = 0 To UBound(arr) - 1 Step 2
Wdth = arr(i + 1) - arr(i)
If Wdth >= 30 Then
Cells(cel.Row, arr(i)).FormulaR1C1 = "=R[-1]C[]"
With Cells(cel.Row, arr(i)).Resize(, Wdth)
.HorizontalAlignment = xlCenterAcrossSelection
.WrapText = True
End With


End If
Next
End If
Next cel
End Sub





Would these be possible changes? If too difficult please let me know.

Thank you!

[mdmackillop]

Try this

Sub test1()
Dim i, x, arr()
Dim rw
Dim cel As Range
Dim Wdth As Long

For Each cel In Range("B:B").SpecialCells(2)
If cel.Interior.ColorIndex = 6 Then _
cel.Offset(, 4).Resize(, 370).ClearContents
Next cel

For Each cel In Range("B:B").SpecialCells(2)
If cel.Interior.ColorIndex = 6 Then
If Not Application.CountA(cel.Offset(1, 3).Resize(, 370)) = 0 Then
cel.Offset(, 4).Resize(, 370).ClearContents
'Range("NI1").Resize(20).ClearContents
ReDim arr(50): x = 0
rw = cel.Row + 1
For i = 5 To 371
If Cells(rw, i) <> Cells(rw, i + 1) Then
If Cells(rw, i) = "" And Cells(rw, i + 1) <> "" Then
arr(x) = i + 1
'Cells(x + 1, 373) = arr(x)
x = x + 1
End If
If Cells(rw, i) <> "" And Cells(rw, i + 1) = "" Then
arr(x) = i
'Cells(x + 1, 373) = arr(x)
x = x + 1
End If
If Cells(rw, i) <> "" And Cells(rw, i + 1) <> "" Then
arr(x) = i
'Cells(x + 1, 373) = arr(x)
x = x + 1
arr(x) = i + 1
'Cells(x + 1, 373) = arr(x)
x = x + 1
End If
End If
Next i
ReDim Preserve arr(x - 1)
For i = 0 To UBound(arr) - 1 Step 2
Wdth = arr(i + 1) - arr(i)
If Wdth >= 30 Then
Cells(cel.Row, arr(i)).FormulaR1C1 = "=R[-1]C[]"
With Cells(cel.Row, arr(i)).Resize(, Wdth)
.HorizontalAlignment = xlCenterAcrossSelection
.Rows.AutoFit
.WrapText = True
End With
End If
Next
End If
End If
Next cel
End Sub

[Katie620]

Wow that is a lot better, thank you so much! :) :)

It still breaks if there is an empty bay, but I think I can live with this issue.

The most important thing is the row height issue which seems to be improved in this version. It does seem that still sometimes text is randomly cut off (where making the row taller manually fixes it). Do you happen to know why that is? If not, or if it's too difficult then I can live with this but just let me know. I can give you an example of rows that cut off some text if you like.

Thanks!

[mdmackillop]

Check that the row is properly clear. With your sample the "blank" row contained one cell which caused this line to fail

If Not Application.CountA(cel.Offset(1, 3).Resize(, 370)) = 0 Then
Retest using >1

[mdmackillop]

I can give you an example of rows that cut off some text if you like.
Please post it

[Katie620]

Check that the row is properly clear. With your sample the "blank" row contained one cell which caused this line to fail

If Not Application.CountA(cel.Offset(1, 3).Resize(, 370)) = 0 Then
Retest using >1

Yeah that's weird it was something in column NG (NG55 specifically for the sample that I attached earlier).If I delete that cell the macro runs file, yet before I delete that cell there seems to be nothing in that cell at all.

Well anyway, I just tested it and this problem seems to be fixed by making sure column NG is always deleted. Thanks for helping me find that!! :)




Please post it

You'll find a sample attached. I have changed it to test it more rigorously and more match what I actually need (so I changed the code to look at days of 8 or longer instead of 30; so if you want to reproduce the output I have, this needs to be done).


But I highlighted in orange the cells where the text is being cut off/row height is not automatically adjusting to fit the tallest cell.

Please note: To make sure the macro consistently shows an ouput where I can see most of the text, after I adjust individual row heights I have found that it is best to highlight rows 12 through 129 and just make them all a uniform height, then run the macro. What height I choose seems to affect which cells are cut off, but no matter what height I pick around this number of cells is always cut off.

[mdmackillop]

Excel is not great at wrapped text row heights. This can be improved if you use a non-proporional text such as Courier. Otherwise you need a workaround. The last line here simply increases the autofit row height

With Cells(cel.Row, arr(i)).Resize(, Wdth)
.HorizontalAlignment = xlCenterAcrossSelection
.Rows.AutoFit
.WrapText = True
End With
Rows(cel.Row).RowHeight = Rows(cel.Row).RowHeight + 13

[Katie620]

Great! Thank you so much once again I even understand the code better now :) Wish I could mark this as solved twice haha. Thank you!

[Katie620]

Hi mdmackillop!

I am so very sorry to bother you again, but with further testing, I have come to a very unusual problem. The macro breaks upon encountering this row of cells:



cust 8
cust63
cust63
cust63
cust63
cust63
cust63
cust63
cust63
cust63
cust63
cust63
cust63
cust63
cust63
cust63
cust63
cust63
cust63
cust63
cust63
cust63
cust7
cust64
cust64
cust64
cust64
cust64
cust64
cust64
cust64
cust64
cust64
cust64
cust64
cust64
cust64
cust64
cust64
cust64
cust59
cust59
cust59
cust59
cust59
cust59
cust59
cust59
cust59
cust59
cust59
cust59
cust59
cust59
cust59
cust64
cust64

cust65
cust65
cust65
cust65
cust65
cust65
cust65
cust65
cust65
cust65
cust65
cust65
cust65
cust65
cust65
cust65
cust65
cust65
cust65
cust65
cust65
cust65
cust65
cust65
cust60
cust60
cust60
cust60
cust60
cust66
cust66
cust66
cust66




I've isolated the problem to this group of cells, but I can't figure out if it is due to the high (63/64) number following 'cust' or is somehow due to the rapid change from one cell to another.

I get "run time error 9" which debug points to arr(x) = i.

I was running the macro to look at changes of 6 or more but even if I change it back to If Wdth >= 30 Then, it still breaks.

Macro free workbook attached just in case, see line 94, the columns which are colored pink.

Any ideas? :)

[mdmackillop]

I didn't allow for enough changes. Just change
ReDim arr(50): x = 0
to
ReDim arr(370): x = 0

[Katie620]

I didn't allow for enough changes. Just change
ReDim arr(50): x = 0
to
ReDim arr(370): x = 0

Perfect, thank you once again!! :) :)