Transpose Col T:W in a sheet with data in Column A: W

[ddander54]

My Data:

Row 1:2 are headers
Columns are A:W
Data starts in Column A:3, A:A is a unique number, never blanks or null

A...B...C...D...etc...T...U...V...W
1...d...t...d...etc...20...30...40...50
2...b...c...d...etc...33...56...78...90
3...e...f...g...etc...21...8...16...55
~200 rows

What I would like is for each row to transpose column T:W at the end of column S

Result:
A...B...C...D...etc...S...T
1...d...t...d...etc...g...20
1...d...t...d...etc...g...30
1...d...t...d...etc...g...40
1...d...t...d...etc...g...50
2...b...c...d...etc...y...33
2...b...c...d...etc...y...56
2...b...c...d...etc...y...78
2...b...c...d...etc...y...90
etc
Note: ... are just to hold the data in somewhat of a column

Initially I thought I could do it with a Pivot table, but that didn't work out (still learning pivot tables), so thought that VBA might be the best way to get the data how I need it, as I'll need to do this every day or so to a new file...

Thanks in advance for any help....
Don

 

[Fluff]

How about

Sub CopyTranspose()

   Dim Cnt As Long
   
   For Cnt = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
      Range("A" & Cnt + 1).Resize(3).EntireRow.Insert
      Range("A" & Cnt).Resize(4, 19).FillDown
      Range("T" & Cnt).Resize(4).Value = Application.Transpose(Range("T" & Cnt).Resize(, 4).Value)
   Next Cnt
   Range("U:W").ClearContents
End Sub

 

[ddander54]

Fluff,

Thanks for the quick response. The VB code works good, except that it also repeats Row 2 (Row 1 & 2 are Headers) 4 times as well. The Transpose functionality seems to be a very slow function as it takes quite awhile to complete the macro, but it seems to do everything I needed on rows 3 thru the last row ......just a little too good on the header.

Don

 

[Fluff]

Missed the bit about the headers

Sub CopyTranspose()

   Dim Cnt As Long
Application.ScreenUpdating = False
   For Cnt = Range("A" & Rows.Count).End(xlUp).Row To 3 Step -1
      Range("A" & Cnt + 1).Resize(3).EntireRow.Insert
      Range("A" & Cnt).Resize(4, 19).FillDown
      Range("T" & Cnt).Resize(4).Value = Application.Transpose(Range("T" & Cnt).Resize(, 4).Value)
   Next Cnt
   Range("U:W").ClearContents
End Sub

Also turned screen updating, which should speed things up

PS
For 200 rows this should be very quick, if it isn't check to see if you have event code running on that sheet.

 

[ddander54]

Fluff,

It's been about 15+ minutes now and its still running. Pardon my ignorance, but how do I check to see if event code is running on this sheet?

Don

 

[Fluff]

On a test with 350 rows it just took ~.5 seconds.

To check for event code right click on the sheet tab containing the data select view code is there any code in the window that opens up?

 

[ddander54]

Just an empty code window when I right click the sheet tab and select View Code.....

 

[Fluff]

Are there any formulae either on that sheet, or looking at it?
Also do you have any conditional formatting, or named ranges?

 

[ddander54]

Yes, there are 5 columns with formula and 1 column with html links. Also the last row is a merged row. So I started the process of elimination to figure out the problem.
First, I Copy/Moved the sheet to a new workbook....waiting for that to get done now, then I was going to copy and PasteSpecial Values to get rid of the formula and html links, then I was going to remove the last merged row to see if I could track down the issue.

There are no Named Ranges in the sheet or Conditional Formatting.

 

[Fluff]

This should deal with the formulae if they are causing the problem. I've also turned events off in case

Sub CopyTranspose()

   Dim Cnt As Long
With Application
   .ScreenUpdating = False
   .Calculation = xlCalculationManual
   .EnableEvents = False
End With

   For Cnt = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
      Range("A" & Cnt + 1).Resize(3).EntireRow.Insert
      Range("A" & Cnt).Resize(4, 19).FillDown
      Range("T" & Cnt).Resize(4).Value = Application.Transpose(Range("T" & Cnt).Resize(, 4).Value)
   Next Cnt
   Range("U:W").ClearContents
With Application
   .Calculation = xlCalculationAutomatic
   .EnableEvents = True
End With
End Sub