Search for string across header row, then search for another string down found column

Hi forum gurus,

I have a worksheet that needs to have its data re-orderd. This seems pretty straight forward, but I'm stumpped on how to use a found cell as the upper limit for another search range.

Basically, I want to find the word "Comment" within (:=xlPart) the text string of header-row cells. When the string "Comment" is found, then I want to look down that column to see if any actual comments are present (four or more letters-- What:="????*").
- If not, then continue to the next column where "Comment" is found in the header.
- If so, then cut the entire column and insert it (sequentially for multiple finds) after column ("H"); then continue to the next column where "Comment" is found in the header and repeat.

I get to the point of selecting the column range I want to search for actual comments, but then my search for comments looks across that row, instead of looking down the column. Here is my annotated vba code:

 Sub LastFndCmmt()
  'Almost works
   Const sFind As String = "Comment"
    Dim ColRng As Long
    Dim LastCol As Integer
    Dim LastRow As Long
        npaste = 1
    
'  Establish limits of data
    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    LastRow = Cells(Cells.Rows.Count, "C").End(xlUp).Row

' Search for "Comment" string in header row
    For ColRng = 1 To LastCol
        Cells.Find(What:=sFind, After:=Range("H1").Offset(0, npaste + 2), LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
       False, SearchFormat:=False).Activate

'begin next search one cell down so that the header string is not part of the search range
        ActiveCell.Offset(1, 0).Select

'Use selected cell as uppermost limit for a range to lastrow of that column
        Range(ActiveCell, ActiveCell.End(xlDown)).Select

'Search down the range for any text string with 4 or more characters
        With ActiveRange
            Cells.Find(What:="????*", After:=ActiveCell, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).EntireColumn.Select

' If a text string is found, then cut the entire column
            If Not Cells Is Nothing Then
                Selection.Cut

' Insert the cut column in successive columns following column "H"
            Columns("H:H").Offset(0, npaste).Select
            Selection.Insert Shift:=xlToRight
            npaste = npaste + 1
               End If
        End With
   Next
End Sub

Thanks very much in advance....

TucsonJack

Could you attach a worksheet (or a mockup of a worksheet)?

Here is a sample worksheet.

Thanks much

I think I got this to work.
Backup your data.

Sub MoveCommentColumns()
    Const sFind As String = "Comment"
    Dim nPasteCol As Long, nCol As Long, nLastCol As Long, nLastRow As Long
    Dim rg As Range, i As Long

    'Paste after column H
    nPasteCol = 8

    '  Establish range of data
    nLastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    nLastRow = Cells(Cells.Rows.Count, "C").End(xlUp).Row
    
    ' Search for "Comment" string in header row
    For nCol = 1 To nLastCol
        If InStr(1, Cells(1, nCol), sFind, vbTextCompare) > 0 Then
            ' Search in Comment Column for any text greater than 4
            Set rg = Range(Cells(2, nCol), Cells(nLastRow, nCol))
            For i = 1 To rg.Rows.Count
                If Len(rg.Cells(i, 1)) > 4 Then
                    rg.EntireColumn.Select
                    rg.EntireColumn.Cut
                    ' Insert the cut column in successive columns following column "H"
                    nPasteCol = nPasteCol + 1
                    Columns(nPasteCol).Insert Shift:=xlToRight
                    Exit For
                End If
            Next i
        End If
   Next nCol
End Sub

StevenM,

Thank you so much. Your most elegant (compared to the clunky way I was approaching the problem) solution worked like a charm. I will study how you did this. I have much to learn.

I haven't discovered how to assign credit to your contribution. I hope the "solved" marker does so. Again... amazingly fine work.. Thank you.

TucsonJack