Twisted Transposing of Cells

[Festus Hagen]

Hi all

I need to transpose some data using links to the original data, unfortunately the original data is in groups of two cells in two rows that needs to be in one row ...

Example source data: ('Sheet1')
E3 F3 G3
E4 F4 G4

Example Target data (Sheet2 or new sheet)
Sheet1!E3 Sheet1!E4 Sheet1!F3 Sheet1!F4 Sheet1!G3 Sheet1!G4

Source data is a Named Range = 'DataRange'

Babble start:
Can you believe someone copies and pastes this by HAND monthly!
Her process, open the read only IT dumped datasource, select all the data copy and paste into her own local sheet, she then copies EACH and EVERY cell by hand onto a new sheet!
Only about 30 columns and a couple thousand rows!
This persons IT says that's the only way!

I am no Excel guru, not even much of an Excel user, but I know better!

Thanks

-Enjoy
fh : )_~

 

[GlennUK]

Your layout is not clear. Are those cells of data or cell references???

Maybe some actual data, before transformation, and after, can be posted?

 

[Festus Hagen]

Your layout is not clear. Are those cells of data or cell references???

Maybe some actual data, before transformation, and after, can be posted?

I used the cell reference as data ...

I hacked this together ... It kinda does the job however it leaves every other row blank and it moves it all over 5 columns right, gotta admit all this twisting and turning has my poor pee brain a smoking ...

Sub TransposeData()
  Dim CurrentCell As Range
  Dim ACell As Range
  Dim ASheet As Worksheet
  Dim NewSheet As Worksheet
  Dim SourceRange As Range
  
  Set ACell = ActiveCell
  Set ASheet = ActiveSheet

  Application.ScreenUpdating = False

  On Error Resume Next
  Set SourceRange = Range("DataRange")
  On Error GoTo 0
  If SourceRange Is Nothing Then Exit Sub
  
  Set NewSheet = Sheets.Add(Type:=xlWorksheet)
  NewSheet.Activate

  For Each CurrentCell In SourceRange.SpecialCells(xlCellTypeConstants)
    CurrentCell.Copy
    If CurrentCell.Row Mod 2 Then
      ' Row 1
      ActiveSheet.Cells(CurrentCell.Row, CurrentCell.Column - 1).Offset(0, CurrentCell.Column + 1).Select
    Else
      ' Row 2
      ActiveSheet.Cells(CurrentCell.Row - 1, CurrentCell.Column).Offset(0, CurrentCell.Column + 1).Select
    End If
    ActiveSheet.Paste link:=True
  Next
  
  ASheet.Select
  ACell.Select
  Application.ScreenUpdating = True
End Sub

Thanks

-Enjoy
fh : )_~

 

[GlennUK]

Using your exact method, but tweaking your loop might help ( see below ):

  For Each CurrentCell In SourceRange.SpecialCells(xlCellTypeConstants)
    CurrentCell.Copy
    ActiveSheet.Cells(Int((CurrentCell.Row + 1) / 2), _
                    SourceRange.Cells(1).Column + _
                    (CurrentCell.Column - SourceRange.Cells(1).Column) * 2 + _
                    ((CurrentCell.Row + 1) Mod 2)).Select
    ActiveSheet.Paste link:=True
  Next

 

[Festus Hagen]

GlennUK ... Absolutely AWESOME!

I'm still reaching for understanding, pretty twisted and I'm far from a mathematician!

Thank you!

Also Thanks to wigi for getting me brain going in this Transposing columns to rows with links thread.

I'll see her this weekend, she will be stunned!

From a day PLUS to a few minutes!
Plus I've added all the needed formatting, formulas and printable report ...

Thank you all for doing what you do!

-Enjoy
fh : )_~

 

[GlennUK]

That's great!

Yes, she will be stunned ... I can't imagine doing that by hand.

 

[mikerickson]

Here is a different approach.

Sub test()
    Dim colNum As Long
    
    On Error Resume Next
        With ThisWorkbook.Names("DataRange").RefersToRange
            For colNum = .Columns.Count To 2 Step -1
                .Columns(colNum).Insert shift:=xlToRight
            Next colNum
            
            .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=IF(MOD(ROW(),2), R[1]C[-1], 1/0)"
            .Value = .Value
            
            Application.Intersect(.EntireColumn, .SpecialCells(xlCellTypeConstants, xlErrors).EntireRow).Delete shift:=xlUp
        End With
    On Error GoTo 0
End Sub

 

[Festus Hagen]

Sorry, been on a trip ...

Mike, Thank you, Much cleaner!
Have not tried it yet, no time for the next few days either ...

I tried to get her to sign on and say to you all what she said to me, she wouldn't ... Probably would not go so well in this public forum either ...
So we'll just leave it with: She's Thrilled!

Thank you all for doing what ya do!

-Enjoy
fh <font color="#FF0000">:</font> )_~