Transpose

First my apologies for the style, I got started on CBM Pet basic and haven't lost the spaghetti coding bug yet.

This works on your current data set and should work no matter how you expand the cols and rows, although I didn't test it fully.

A few points

1. the original data should be on a worksheet called "ORIGINAL" and the output sheet created as "output"...basically just as they are now.
2. The header "Blank" must be in the relative place as it appears in your original.
3. To achieve your exact result you should delete your unwanted cols in the output like "Area" or whatever.
That's about it.

Sub trans()



Dim col As Integer

Dim origrow As Integer

Dim outrow As Integer

Dim datcol As Integer



outrow = 1



label1:

col = col + 1

If Worksheets("ORIGINAL").Cells(1, col) = "Blank" Then GoTo label2

datcol = col

Worksheets("Output").Cells(1, col + 1) = Worksheets("ORIGINAL").Cells(1, col)

GoTo label1

label2:

col = col + 1

origrow = 1

label3:

outrow = outrow + 1

origrow = origrow + 1

Worksheets("Output").Cells(outrow, 1) = Worksheets("ORIGINAL").Cells(1, col)

For x = 1 To (datcol)

Worksheets("Output").Cells(outrow, x + 1) = Worksheets("ORIGINAL").Cells(origrow, x)



Next x

Worksheets("Output").Cells(outrow, x + 1) = Worksheets("ORIGINAL").Cells(origrow, col)

If Worksheets("ORIGINAL").Cells(origrow + 1, col) <> 0 Then GoTo label3

If Worksheets("ORIGINAL").Cells(1, col + 1) <> 0 Then GoTo label2



End Sub

Brief explanation how it works.
The macro scans along the header row writing all it finds into the output until it hits "Blank"
It will then take the value of the next col (Date) and place it in col A row1 and populate the rest of the row.
It will then check to see if the next row has data, etc until cell is empty, it will then check to see if the next date header isn't empty and carry on.

Hope it does the trick, but I'm sure it wouldn't need much tinkering to sort it.
best of luck

col

Just read your code pike and although you put me to shame (not hard really) I think the header "Blank" is quite important to the scheme as I think columns could be added or taken away, thus making "Blank" an "end of headers" marker, dates now follow.

Hello Guys,

Thanks for the response.

All of the codes worked fine for the given workbook but they are not completely generic.

I have coded it to be generic to any kind of data with any position of the blank column (except last).

But there is just one issue,

The code takes a hell lot of time to execute when inserting a row.

Pike and Col12345, please do help me make this thing a bit quicker.

' Macro3 Macro
'

'
Dim x As Long
Dim col As Long
Dim xr As Long

Application.ScreenUpdating = False
Sheets(1).Select
    Range("A2").Select
    Selection.End(xlToRight).Select
    Selection.End(xlToRight).Select
    Range(Selection, Selection.End(xlToRight)).Select
    x = Selection.Columns.Count
    MsgBox (x)
    
    'title
    
    Rows("1:1").Select
    Selection.Copy
    Sheets(2).Select
    Rows("1:1").Select
    ActiveSheet.Paste
    
    'rows beneath title
    
    Sheets(1).Select
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets(2).Select
    
    Range("A2").Select
    For col = 1 To x
     'MsgBox (x)
    'Sheets(1).Select
    'Range(Selection, Selection.End(xlToRight)).Select
    'Range(Selection, Selection.End(xlDown)).Select
    'Selection.Copy
    'Sheets(2).Select
    
    ActiveSheet.Paste
    
   Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    'Range("A15").Select
    'Sheets(1).Select
Next col

'Bring columns down

'First Column
Sheets(1).Select
    Range("A2").Select
    Selection.End(xlToRight).Select
    Selection.End(xlToRight).Select
    Range(Selection, Selection.End(xlDown)).Select
     xr = Selection.Rows.Count
    Application.CutCopyMode = False
    Selection.Copy
    Sheets(2).Select
    Range("A2").Select
    Selection.End(xlToRight).Select
    ActiveCell.Offset(0, 2).Select

    
    'Rest Column
  For col = 1 To x
      ActiveSheet.Paste
  Sheets(1).Select
      ActiveCell.Offset(0, 1).Select
    Range(Selection, Selection.End(xlDown)).Select
    'Application.CutCopyMode = False
    Selection.Copy
    Sheets(2).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    
    'ActiveSheet.Paste
    
    'Application.CutCopyMode = False
    Next col
    
    'insert new row
    
     Sheets(2).Select
     Range("A1").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

Sheets(1).Select
Range("A2").Select
    Selection.End(xlToRight).Select
    Selection.End(xlToRight).Select
     ActiveCell.Offset(-1, 0).Select
    Selection.Copy
    Sheets(2).Select
    Range("A2").Select
    For col = 1 To xr
    ActiveSheet.Paste
       ActiveCell.Offset(1, 0).Select
       Next
       
       'Repeat for Next years
       For j = 0 To x - 2
       Sheets(1).Select
       ActiveCell.Offset(0, 1).Select
       Selection.Copy
       Sheets(2).Select
       
       For col = 1 To xr
    ActiveSheet.Paste
       ActiveCell.Offset(1, 0).Select
       'ActiveCell.Offset(1, 0).Select
       Next
              Next
           Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A2").Select
              Selection.End(xlToRight).Select
    Selection.End(xlToRight).Select
ActiveCell.Offset(-1, 0).Select
    Selection.ClearContents
    
    ActiveCell.FormulaR1C1 = "Volume"
      ActiveCell.Offset(0, 1).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.ClearContents

sorry my knowledge of VBA is very limited and most of your code goes straight over my head.

My apologies for doubting you.

sorry to disappoint, but my VBA skills are limited, pike and TMshucks are clearly your best bet.