Macro to Change Header in Row 1

[Michael151]

<!--[if gte mso 9]><xml> <w:WordDocument> <w:View>Normal</w:View> <w:Zoom>0</w:Zoom> <w:Compatibility> <w:BreakWrappedTables/> <w:SnapToGridInCell/> <w:WrapTextWithPunct/> <w:UseAsianBreakRules/> </w:Compatibility> <w:BrowserLevel>MicrosoftInternetExplorer4</w:BrowserLevel> </w:WordDocument> </xml><![endif]--><!--[if gte mso 10]> <style> /* Style Definitions */ table.MsoNormalTable {mso-style-name:"Table Normal"; mso-tstyle-rowband-size:0; mso-tstyle-colband-size:0; mso-style-noshow:yes; mso-style-parent:""; mso-padding-alt:0in 5.4pt 0in 5.4pt; mso-para-margin:0in; mso-para-margin-bottom:.0001pt; mso-pagination:widow-orphan; font-size:10.0pt; font-family:"Times New Roman";} </style> <![endif]--> Hello all,

Trying to write a macro that will replace the header in row 1 based on the contents of that column.

In the row 1 header, there is a column marked “System”. I’d like to change this header to the first four letters of the first cell in this column that isn’t blank or contains the word “OPEN.”

For example:

Before:

SYSTEM
OPEN
OPEN
RTSG

After:

RTSG
OPEN
OPEN
RTSG

Another example with a blank cell in row 2:

Before:

SYSTEM

OPEN
RTSF

After:

RTSF

OPEN
RTSF


Any help is most appreciate - thank you!

 

[Michael151]

This would be something like:

Find: "System" in Rows(1:1)

Within Found Column:

Find First Cell <> "OPEN" or <> * (blank cell)

With Found Cell, take First 4 Characters

Move to header and replace "System" in Rows(1:1)

 

[Michael151]

Just wondering if anyone had any ideas on this?

Thanks.

 

[Rasm]

Try something like this

ThisWorkBook

Option Explicit
Option Compare Text
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Select Case Target.Column
        Case 1
            if Target.row <> 1 then exit sub
            i = 2
            Do Until Not IsEmpty(ActiveSheet.Cells(i, Target.Column).Value) And Trim(ActiveSheet.Cells(i, TargetColumn).Value) <> "Open"
                i = i + 1
                If i > 65000 Then MsgBox "Hmmmmm": Exit Sub
            Loop
            ActiveSheet.Cells(1, TargetColumn.Value) = ActiveSheet.Cells(i, TargetColumn).Value
            Exit Sub
        Case 2
            MsgBox "Do what you like"
    End Select
End Sub

 

[mirabeau]

Sub changeheader()
Dim coln As Integer, e, nd
coln = Application.Match("system", Cells.Resize(1), 0)
If Not IsError(coln) Then
    nd = Cells(Rows.Count, coln).End(3).Row
    For Each e In Cells(2, coln).Resize(nd)
        If (e <> "") And (e <> "OPEN") Then Cells(1, coln) = e: Exit For
    Next
End If
End Sub

Match case???

 

[Rasm]

Correction


ActiveSheet.Cells(1, Target.Column).Value =

 

[Michael151]

Thanks all - that worked!