Find values in columns and cut and paste the range of cells from columns to rows

I have set of data which I want to transpose from columns to rows.. the data has same 17 headers and 25 rows of data for different companies one after another in columns and I want the same to be transposed into rows..so first I am finding the starting column name with the identifiable text and then from that column I am selecting 16 columns to right and 25 rows down range to cut and paste data .i.e. to append in the last row of Column D. I want to run this in loop till the all the columns data in right is cut and pasted in the rows one below another...but I run the below code which I have so far, it gets stuck in loop..

Code:

---

Sub test()
Dim rng As Range
Dim cell As Range
Dim search As String
Dim lRow As Long
lRow = Cells(Rows.Count, 4).End(xlUp).Row + 1
Set rng = ActiveSheet.Columns("U:XFD")
search = "IS_AUDITOR"
Set cell = rng.Find(What:=search, LookIn:=xlFormulas, LookAt:=xlWhole, MatchCase:=False)

If cell Is Nothing Then
    Exit Sub
Else
Do While cell.Value <> ""
cell.Select
 Range(ActiveCell, ActiveCell.Offset(25, 16)).Cut
 Range("D" & lRow).Select
 ActiveSheet.Paste

End If
Loop
End Sub

---

You're not "moving" the cell/ActiveCell forward.
Put "Set Cell = rng.Find....." incl. your "If Cell is nothing" into the loop (at the start of the loop)
And put the Loop-condition at the end of the loop (Do .. Loop Until)

EDIT: Untested!

Code:

---

Sub test()
Dim rng As Range
Dim cell As Range
Dim search As String
Dim lRow As Long
lRow = Cells(Rows.Count, 4).End(xlUp).Row + 1
Set rng = ActiveSheet.Columns("U:XFD")
search = "IS_AUDITOR"
Do
 Set cell = rng.Find(What:=search, LookIn:=xlFormulas, LookAt:=xlWhole, MatchCase:=False)
 If cell Is Nothing Then Exit Do
 cell.Select
 Range(ActiveCell, ActiveCell.Offset(25, 16)).Cut
 Range("D" & lRow).Select
 ActiveSheet.Paste
Loop Until cell.Value = ""
End Sub

---

It cuts the data correctly but keeps pasting the data in the same cell in column D which means it's overwriting previously pasted data, it's suppose to select the last blank cell in Column D everytime but it's not doing the same.

Quote:

---

Originally Posted by Zvoni

You're not "moving" the cell/ActiveCell forward.
Put "Set Cell = rng.Find....." incl. your "If Cell is nothing" into the loop (at the start of the loop)
And put the Loop-condition at the end of the loop (Do .. Loop Until)

EDIT: Untested!

Code:

---

Sub test()
Dim rng As Range
Dim cell As Range
Dim search As String
Dim lRow As Long
lRow = Cells(Rows.Count, 4).End(xlUp).Row + 1
Set rng = ActiveSheet.Columns("U:XFD")
search = "IS_AUDITOR"
Do
 Set cell = rng.Find(What:=search, LookIn:=xlFormulas, LookAt:=xlWhole, MatchCase:=False)
 If cell Is Nothing Then Exit Do
 cell.Select
 Range(ActiveCell, ActiveCell.Offset(25, 16)).Cut
Range("D" & lRow).Select
 ActiveSheet.Paste
Loop Until cell.Value = ""
End Sub

---

---

Move the lRow=Cells..... into the Loop as the first line after the "Do"