VBA - find and move cells

[sjs1967]

I would be very thankful for some help. I have a spreadsheet from a text download so data appears in different columns in different rows. For example, my "inclusions" may appear in R3, Q4, P2, etc., followed by the specific inclusions in S3, R4, Q2 and so on. I am trying to line up the cells that say "inclusions" in column S and have the specific inclusions follow accordingly in lined up columns. Here is my code that I tried but am having problems with:

' to move the inclusion column over

Columns("R:R").Select

Do While Selection.find(What:="inclusions", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _MatchCase:=False, SearchFormat:=False) = True
ActiveCell.Activate
ActiveCell.Insert Shift:=xlToRight
Loop

My next lines of code would be for column Q and I would shift it 2 cells to the right and so on so that "inclusions" will be in column S. Today I got a syntax error. I'm sure it's an easy fix, but I'm just learning VBA so any advice will help. Thanks!

 

[John_w]

Try this. It looks for "inclusions" in columns P to R and aligns them in column S. The code can also align columns to the right of column S by deleting cells to the left, however this is only done if you include columns T and beyond in the Find, e.g. change the Set foundRange = Columns("P:R") to Set foundRange = Columns("P:Z").

Option Explicit

Public Sub Align_Column_S()

    Dim foundRange As Range
    Dim firstFoundRow As Long
    Const Column_S = 19
        
    Set foundRange = Columns("P:R").Find(What:="inclusions", LookIn:=xlValues, LookAt:=xlPart, _
        SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

    If Not foundRange Is Nothing Then
        firstFoundRow = foundRange.Row
        
        Do
            With foundRange
                If .Column < Column_S Then
                    'Align by inserting cell(s) before column S
                    .Cells.Resize(1, Column_S - .Column).Insert Shift:=xlToRight
                ElseIf .Column > Column_S Then
                    'Align by deleting cell(s) after column S
                    .Cells.Offset(0, Column_S - .Column).Resize(1, .Column - Column_S).Delete Shift:=xlToLeft
                End If
            End With
            
            'Look for text again
            Set foundRange = Cells.FindNext(foundRange)
            
        Loop Until foundRange.Row <= firstFoundRow
        
    End If
    
End Sub

 

[sjs1967]

Hi John,
Brilliant! Thank you!

I think I even understand what you did. It sets a value for the row where it finds "inclusions", and then if it finds another instance in the same row it loops because the foundrangerow will be smaller than the next found range row. When both of the values are zero, it stops the loop. Is that it?

 

[John_w]

No, it uses a standard Find-FindNext loop (see the VB help for FindNext) to search for "inclusions" wherever they occur in columns P-R, and then inserts the required number of cells to align it in column S. Note that there is a bug in my original code which means that an "inclusions" occuring in P1 would not be aligned - because P1 would be found last (the Find actually starts after P1), but the loop exits before then because Loop Until foundRange.Row <= firstFoundRow, which should be Loop Until foundRange.Row = firstFoundRow.

Here is an improved version which fixes this bug, along with separate steps which show how the alignment is done. If you step through the code in the VB editor (F8) you should get a better idea of how it works.

Public Sub Align_Column_S_v2()

    Dim foundRange As Range
    Dim firstFoundRow As Long
    Dim foundAddress As String
    Const Column_S = 19
        
    Set foundRange = Columns("P:R").Find(What:="inclusions", LookIn:=xlValues, LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False)

    If Not foundRange Is Nothing Then
        firstFoundRow = foundRange.Row
        
        Do
            With foundRange
                foundAddress = foundRange.Address
                
                'Align by inserting cell(s) before column S
                '.Resize(1, Column_S - .Column).Insert Shift:=xlToRight
                
                'Or using multiple steps
                .Select
                Selection.Resize(1, Column_S - .Column).Select
                Selection.Insert Shift:=xlToRight
                
            End With
                       
            'Look for text again
            Set foundRange = Columns("P:R").FindNext(Range(foundAddress))
            If foundRange Is Nothing Then Exit Do
            
        Loop Until foundRange.Row = firstFoundRow
        
    End If
    
End Sub