Find, Copy, Transpose, Repeat

**siddharthariver** · 01-11-2010, 05:24 PM

I don't know how to write code, so I'm hoping one of you intelligent people can help me out. I've been looking all around for a VBA code that will:

1 - Search down column A for the word "ADDRESS"
2 - Once "ADDRESS" is found, I need to copy that cell along with the two cells directly above it (therefore, copying three cells) and transpose these cells' contents to the three columns to the right
3 - I need this action performed down the entire column, which contains about 18,000 instances of "ADDRESS". The amount of rows between these instances varies and sometimes these in-between rows contain data and other times they don't contain data.

Thanks for any help you can give me with this.

**davegugg** · 01-11-2010, 06:05 PM

Here ya go:

Code:

Public Sub siddharthariver()

Application.ScreenUpdating = False
For a = 1 To ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
    If InStr(Cells(a, "A"), "ADDRESS") > 0 Then
        Range(Cells(a - 2, "A"), Cells(a, "A")).Copy
        Cells(a, "B").PasteSpecial Transpose:=True
    End If
Next a
Cells(1, 1).Activate
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Please note "ADDRESS" is case sensitive.

**Palmetto** · 01-11-2010, 06:06 PM

Perhaps this will get you started. Upload a sample workbook of you need more help or this isn't working for you.

Code:

Option Explicit

Sub transpose_Data()

    Dim c As Range, lrow As Long
    
    lrow = Cells(Rows.Count, 1).End(xlUp).Row
    
    Application.ScreenUpdating = False
    
    On Error Resume Next
    For Each c In Range("A1:A" & lrow)
        If c.Value = "Address" Then
            Range(Cells(c.Row - 2, 1), Cells(c.Row, 1)).Copy
            c.Offset(0, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
        End If
    Next c
    
    Application.ScreenUpdating = True
    Application.CutCopyMode = False

End Sub