Excel VBA question 1

[xitu]

I have the following VBA code in Excel:

=====================================================
Sub del_headers()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim rng As Range, ix As Long
Set rng = Intersect(Range("A:A&quot, ActiveSheet.UsedRange)
For ix = rng.Count To 1 Step -1
If rng.Item(ix).Interior.ColorIndex = 3 Then
rng.Item(ix).EntireRow.Delete
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub
=====================================================

This code will go through column A and delete all the red rows (headers)
(Note: White rows following by red rows are details)

Please take a look at:

http://viet.ws/headers.xls

My question:
From the above code, how do I modify to get:

Loop through column A
If detail cells are blanked
Copy the formula from its header
Paste this formula into blanked cells (details)
End If
End Loop


Many thanks
XT

 

[VBAjedi]

Well, this SHOULD do it. . . it won't leave any blank rows, though! If you want a blank row above each header, you would have to put a space or something in the cell above the header so the code doesn't think it's blank.

Sub RefreshFormulas()
    Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Dim rng As Range, ix As Long
  Dim CurrFormula As String
  
  Set rng = Intersect(Range("A:A"), ActiveSheet.UsedRange)
  For ix = 1 To rng.Count
      If rng.Item(ix).Interior.ColorIndex = 3 Then
         CurrFormula = rng.Item(ix).Formula
      ElseIf Len(rng.Item(ix).Formula) = 0 Then
         rng.Item(ix).Formula = CurrFormula
      End If
  Next
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True

End Sub

VBAjedi

 

[xitu]

It works like a charm.

Many thanks,
XT

 

[xitu]

VBAjedi (and others),

Back to your answer, another issue is coming up:
If the headers are blanked, how do I insert the value for them(it should be in this format:
AAAAxxxx where xxxx starts with 0001 and increases until the last emptied header)

Thanks a bunch,
XT

 

[VBAjedi]

You're going to be putting a lot of confidence in the color formatting being correct on this sheet! I would think a sheet redesign would be best.

But, if that's not possible, this might work for you:

Sub RefreshFormulas()
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Dim rng As Range, ix As Long
  Dim CurrFormula As String
  Dim x

  Set rng = Intersect(Range("A:A"), ActiveSheet.UsedRange)
  For ix = 1 To rng.Count
      If rng.Item(ix).Interior.ColorIndex = 3 Then
         If Len(rng.Item(ix).Formula) > 0 Then
            CurrFormula = rng.Item(ix).Formula
         Else
            x = x + 1
            CurrFormula = "AAAA" & Right("000" & x, 4)
            rng.Item(ix).Formula = CurrFormula
         End If
      ElseIf Len(rng.Item(ix).Formula) = 0 Then
         rng.Item(ix).Formula = CurrFormula
      End If
  Next
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

Let me know if that does the trick!

VBAjedi

 

[VBAjedi]

Actually, that won't work because a subsequent header could have the same value as what you just created. . .

If you're missing headers you may be better off just rewriting ALL of them every time. Just take the Len() check out of my last routine so it rewrites the formulas every time.

VBAjedi

 

[xitu]

VBAjedi,

Again, it works perfect.

Thank you very much,
XT