Copy, transpose and move using VBA

[nishant_kotian]

I have a data range from lets say A5:A15.

I wanted to copy(capture) this data from Sheet 1 on to Sheet 2 lets say from A1:J1 in a transposed format(on sheet 2).

However once I change the data from A5:A15 on sheet 1 and again run the macros, it should now be captured on Sheet 2 from A2:J2 in a transposed format again.

Your help is highly appreciated.

Thanks in advance.

 

[cstimart]

This thread might help you...

http://www.mrexcel.com/forum/showthread.php?t=580272

 

[JoeMo]

Try this (A5:A15 is 11 rows so the transpose covers A:K not A:J as you posted):

Sub CopyAndTransposeData()
Dim sh1 As Worksheet, sh2 As Worksheet, r1 As Range, lRw As Long

Set sh1 = ThisWorkbook.Sheets("Sheet1")
Set sh2 = ThisWorkbook.Sheets("Sheet2")
Set r1 = sh1.Range("A5:A15")
lRw = sh2.Range("A" & Rows.Count).End(xlUp).Row
r1.Copy
With sh2
    If IsEmpty(.Range("A1")) Then
        .Range("A" & lRw).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    Else
        .Range("A" & lRw + 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    End If
End With
Application.CutCopyMode = False
End Sub

 

[Rick Rothstein]

Here is another macro for you to try...

Sub CopyAndTransposeData()
  Dim LastRow As Long, SourceRange As Range, Destination As Worksheet
  
  Set SourceRange = Sheets("Sheet1").Range("A5:A15")
  Set Destination = Sheets("Sheet2")
  
  On Error Resume Next
  LastRow = Destination.Columns("A").Resize(, SourceRange.Count).Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
  Destination.Cells(LastRow + 1, "A").Resize(, SourceRange.Count).Value = WorksheetFunction.Transpose(SourceRange)
End Sub

 

[Rick Rothstein]

Here is a modification to my previously posted code that gives you a little more flexibility in setting the destination column location (just change the two Set statements to match your actual setup)...

Sub CopyAndTransposeData()
  Dim LastRow As Long, SourceRange As Range, DestinationStartColumn As Range
 
  Set SourceRange = Sheets("Sheet1").Range("A5:A15")
  Set DestinationStartColumn = Sheets("Sheet2").Columns("A")
 
  On Error Resume Next
  LastRow = DestinationStartColumn.Resize(, SourceRange.Count).Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
  Intersect(Rows(LastRow + 1), DestinationStartColumn.Resize(, SourceRange.Rows.Count)).Value = WorksheetFunction.Transpose(SourceRange)
End Sub

 

[nishant_kotian]

Try this (A5:A15 is 11 rows so the transpose covers A:K not A:J as you posted):

Sub CopyAndTransposeData()
Dim sh1 As Worksheet, sh2 As Worksheet, r1 As Range, lRw As Long

Set sh1 = ThisWorkbook.Sheets("Sheet1")
Set sh2 = ThisWorkbook.Sheets("Sheet2")
Set r1 = sh1.Range("A5:A15")
lRw = sh2.Range("A" & Rows.Count).End(xlUp).Row
r1.Copy
With sh2
    If IsEmpty(.Range("A1")) Then
        .Range("A" & lRw).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    Else
        .Range("A" & lRw + 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    End If
End With
Application.CutCopyMode = False
End Sub

Thanks a ton buddy!!!

 

[nishant_kotian]

Try this (A5:A15 is 11 rows so the transpose covers A:K not A:J as you posted):

Sub CopyAndTransposeData()
Dim sh1 As Worksheet, sh2 As Worksheet, r1 As Range, lRw As Long

Set sh1 = ThisWorkbook.Sheets("Sheet1")
Set sh2 = ThisWorkbook.Sheets("Sheet2")
Set r1 = sh1.Range("A5:A15")
lRw = sh2.Range("A" & Rows.Count).End(xlUp).Row
r1.Copy
With sh2
    If IsEmpty(.Range("A1")) Then
        .Range("A" & lRw).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    Else
        .Range("A" & lRw + 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    End If
End With
Application.CutCopyMode = False
End Sub

Thanks a ton buddy!!!