Macro to transpose data to fill blank cells in table

[Guest]

Good evening

I'm trying to write a macro to transpose data to fill blank cells in a table
so in the example below it needs to find the first blank cell in row 2 (C2)
and copy the info in B3:B6 and transpose it into cells C2:F2. It then needs
to find the first blank cell in row 3 and repeat the sequence

A1 B C D E F
2 100
3 90 100
4 80 80 100
5 70 60 70 100
6 60 40 35 60 100

I need this to work on a table of any size so the macro needs to keep going
until it recognises it's at the end of the table.

I'm afraid I'm out of my depth here so any help would be much appreciated.

Thanks a lot

Kewa

 

[Toppers]

Hi,
Try this which assumes Row 1 is ALWAYs empty as per your description.

Sub TranposeData()

Dim lastrow as long
Dim R as Long, C as integer

lastrow = Cells(Rows.Count, "A").End(xlUp).Row


For R = 2 To lastrow - 1
C = Cells(R, Columns.Count).End(xlToLeft).Column
Range(Cells(R + 1, C), Cells(lastrow, C)).Copy
Cells(R, C + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=True
Next R

Application.CutCopyMode = False
End Sub


HTH

 

[Guest]

That's briliant, thank you.

How can I amend this so the macro is based on the cell at the top left
corner of the table wherever that was on the sheet?

I was thinking of having a button to start the macro, locating that next to
the table.

Thanks again

 

[Toppers]

Hi,
The easiest way is to select the cell in the top left hand corner and
THEN call the macro. The "set rng=activecell" is used to determine the
address (row/coumn) of the cell.

Alternatively, if the matrix is surrounded by blanks i.e. is not a sub-set
of a larger matrix (set of data) then the "set rng=Activesheet.UsedRange"
could be used - no need to select cell.

Comment out or remove appropriate statement.

HTH


Sub TranposeData()

Dim lastrow As Long
Dim R As Long, C As Integer
Dim rng As Range

Set rng = ActiveSheet.UsedRange
' Or select cell in top left corner of matrix BEFORE calling macro
Set rng = ActiveCell

lastrow = Cells(Rows.Count, rng(1).Column).End(xlUp).Row

For R = rng(1).Row To lastrow - 1
C = Cells(R, Columns.Count).End(xlToLeft).Column
Range(Cells(R + 1, C), Cells(lastrow, C)).Copy
Cells(R, C + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=True
Next R

Application.CutCopyMode = False

End Sub

 

[Guest]

Hi

Thanks a lot for your help with this. I think I'm nearly there now.

Because my table is in the middle of a sheet with other data a few rows
above, below and in columns to the right the code was copying data from
beyond my table. After a lot of trial and error (all part of my giant
learning curve) I've modified the code so it seems to do exactly what I want
except when it gets to the bottom right cell it continues the process and
doesn't recognise that it's reached the end of the table.

Do I need to put something in somewhere that says if the cell to the right
and the cell below are blank then stop? If so how would I include that in
this macro?

Sub TranposeData()

Dim lastrow As Long
Dim R As Long, C As Integer
Dim rng As Range

ActiveCell.Offset(1, 1).Activate

' Set rng = ActiveSheet.UsedRange
' Or select cell in top left corner of matrix BEFORE calling macro
Set rng = ActiveCell

lastrow = ActiveCell.End(xlDown).Row

For R = rng(1).Row To lastrow
C = Cells(R, Columns.Count).End(xlToLeft).Column
Range(Cells(R + 1, C), Cells(lastrow, C)).Copy
Cells(R, C + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True
Next R

Application.CutCopyMode = False

End Sub


Thanks again for the help.

Kewa

 

[Toppers]

Hi,
I note you made changes to the statement"lastrow= .." and the "For R
= " loop. Without seeing an example of your data, I am not sure if these work
or whether my original would. My original logic worked on the premise that
there are blanl cells to act as "end of data" markers.

Can you send me an example spreadsheet to look at?
([email protected])