Copy Data Paste another Workbook Transpose Automatically using Excel VBA

How to copy data, paste it in another workbook while transposing the pasted data using VBA.

  • First select the data
  • Next copy it
  • Open the workbook in which you wish to paste it
  • Find the next empty or blank column
  • Select a cell next to the column containing data like headers
  • Now paste the data using paste special so that you can also transpose the data

The complete VBA code is given below;

Private Sub CommandButton1_Click()

ActiveSheet.Range(“A2:F4″).Copy
Workbooks.Open Filename:=”C:\Users\takyar\Desktop\copied-employee-data.xlsx”
eColumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
If eColumn >= 1 Then eColumn = eColumn + 1
ActiveSheet.Cells(1, eColumn).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, Skipblanks:=False, Transpose:=True
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False

End Sub

Watch the video on YouTube


17 thoughts on “Copy Data Paste another Workbook Transpose Automatically using Excel VBA”

      1. Sir… awesome tutorials THANKS 🙂

        Like Bill, I am also facing issues while transposing columns from one Workbook to rows in another Workbook. Tried your methodology but its ending with error 1004.
        Unfortunately, there is no help available online on transposing from horizontal to vertical from different workbooks. Can you pl guide ? It will be of great help to me and all.

    1. Sirji I work on cash collection counter need cash denomination control system by using Excel for avoid difference in cash with count transaction

  1. Hello Sir
    Above code works great. but my data is in single column so whenever I use this code it transpose data in same row only, If want to Transpose like first eight cells of column in first row, Next eight cells in next row and so on. So please share the code for this.

  2. dear sir
    thank you to every thing that you give us . i have question
    how can i copy that data in rows and what will we do if that cells have result from FX
    thank you

  3. Dears ,

    I have a question regarding the VBA codes.
    I want to copy data “specific columns” from opened excel file (excel file is attachment in outlook – Name of the file in outlook attachment looks like: 20171011__GAMA_Programi i aprovuar.xlsx and changes everyday ) and to paste transpose them into another workbook on my PC.
    How can I do this automatically with VBA macro (codes) by one Button taking into account change of the file name everyday( (without changing manually the name of the attached file).
    I appreciate your help

    Thanks in advance.
    Best regards

  4. i have to copy a column(Column header = “contract#”) that is in another workbook and this workbook has multiple sheets. we have to check in every sheets of workbook.

  5. Hello,

    I am trying to do the same thing but with rows and I get an error “Pastespecial method of range class failed” Everything works minus the paste, unless I open the second workbook and select a cell.

    ActiveSheet.Range(“LL_Data”).Copy

    Workbooks.Open Filename:=”C:\……x”
    ActiveSheet.Unprotect Password:=”Secret”
    erow = Sheets(“DiscoveredLessons”).Cells(Rows.Count, “A”).End(xlUp).Offset(0).Row
    If erow >= 1 Then erow = erow + 1
    ActiveSheet.Cells(erow, 1).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    ActiveSheet.Protect Password:=”Secret”
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    ActiveSheet.Unprotect Password:=”190″
    Sheets(“Sheet1”).Range(“LL_Data”).ClearContents
    ActiveSheet.Protect Password:=”190″
    ActiveWorkbook.Save

  6. This is to format a xlsm workbook, creat xlxs workbooks and email them.

    Option Explicit

    Sub Macro1()
    Call formatWorkSheet
    Call SaveAsString
    End Sub

    Sub Macro2()
    Call DeleteColumns
    ‘ Call SendEmails
    Call del_xlsxFiles
    Call deleteColNthiswb
    End Sub

    ‘1. format the worksheet and insert data in columns N and O
    Sub formatWorkSheet()
    Dim i As Integer
    Dim lRow As Integer
    lRow = Sheets(“Sheet1”).Range(“A” & Rows.Count).End(xlUp).Row
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    Columns(“J:N”).Select
    Selection.Delete Shift:=xlToLeft
    Range(“J1”).Select
    ActiveCell.FormulaR1C1 = “REG or ORP”
    Range(“K1”).Select
    ActiveCell.FormulaR1C1 = “C C Code”
    Range(“L1”).Select
    ActiveCell.FormulaR1C1 = “Discharging?”
    Range(“M1”).Select
    ActiveCell.FormulaR1C1 = “Disch Date”
    Range(“N1”).Select
    ActiveCell.FormulaR1C1 = “Save As”
    Range(“O1”).Select
    ActiveCell.FormulaR1C1 = “Email Address”
    Range(“J2”).Select

    Rows(“1:1”).Select
    Selection.Font.Bold = True
    With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
    End With

    For i = 2 To lRow
    Range(“N” & i).Select
    ActiveCell.FormulaR1C1 = “=TEXT(RC[-8], “”YYYYMMDD””) & “” LPA “” & RC[-12] & “”, “” & RC[-11] & “” “”& RC[-13]”
    Range(“N” & i + 1).Select
    Next i

    For i = 2 To lRow
    Range(“O” & i).Select
    ActiveCell.FormulaR1C1 = “raghu.prabhu@gmail.com”
    Range(“O” & i + 1).Select
    Next i

    Cells.Select
    Selection.Columns.AutoFit
    Range(“A1”).Select
    ActiveWorkbook.Save
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    End Sub

    ‘2. Create files
    Sub SaveAsString()
    Dim i As Integer
    Dim lRow As Integer
    Dim sPath As String
    Dim sFileName As String
    Dim oFilename As String
    oFilename = “zMaster” ‘ Change “Book1” to the name of the original workbook
    sPath = ThisWorkbook.Path
    lRow = Sheets(“Sheet1”).Range(“A” & Rows.Count).End(xlUp).Row

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    For i = 2 To lRow

    Range(“A” & i & “:” & “M” & i).Select
    With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 65535
    .TintAndShade = 0
    .PatternTintAndShade = 0
    End With

    sFileName = Range(“N” & i).Value
    ActiveWorkbook.SaveAs fileName:=sPath & “\” & sFileName & “.xlsx”, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

    Range(“A” & i & “:” & “M” & lRow).Select
    With Selection.Interior
    .Pattern = xlNone
    .TintAndShade = 0
    .PatternTintAndShade = 0
    End With

    Next i

    Workbooks.Open fileName:=sPath & “\” & oFilename & “.xlsm”
    Workbooks.Open fileName:=sPath & “\” & sFileName & “.xlsx”
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    ActiveWorkbook.Close
    End Sub
    ‘3. Delete columns in all the files created
    Sub DeleteColumns()

    Dim wbOpen As Workbook
    Dim MyDir As String
    MyDir = ActiveWorkbook.Path ‘ current path
    Dim strExtension As String

    strExtension = Dir(MyDir & “\*.xlsx”)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    While strExtension vbNullString
    Set wbOpen = Workbooks.Open(MyDir & “\” & strExtension)

    Call deleteColN

    strExtension = Dir
    Wend
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    End Sub

    Sub deleteColN()
    Columns(“N:O”).Select
    Selection.Delete Shift:=xlToLeft
    Range(“A1″).Select
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    End Sub

    ‘4. Send Emails.
    ‘https://www.youtube.com/watch?v=0k8t2Fy6nSc
    Sub SendEmails()
    Dim EmailAddress As String
    Dim SubjectString As String
    Dim MessageString As String
    Dim sFileName As String
    Dim OutLookApp As Object
    Dim OutLookMailItem As Object
    Dim MyAttachments As Object
    Dim sPath As String
    Dim LastRow As Integer
    Dim Attachment As String
    Dim x As Integer

    x = 2
    Do While Sheet1.Cells(x, 1) ” ”

    Set OutLookApp = CreateObject(“Outlook.Application”)
    Set OutLookMailItem = OutLookApp.CreateItem(0)
    Set MyAttachments = OutLookMailItem.attachmets
    sPath = ActiveWorkbook.Path & “\”

    EmailAddress = Sheet1.Cells(x, 15)
    SubjectString = Sheet1.Cells(x, 14) & ” [SEC=CLASSIFIED]”
    sFileName = Sheet1.Cells(x, 14) & “.xlsx”
    Attachment = sPath + sFileName

    MsgBox EmailAddress
    OutLookMailItem.To = EmailAddress
    OutLookMailItem.Subject = SubjectString
    OutLookMailItem.Body = “Please finD LPA for this fortnight” & vbCrLf & “Regards ” & vbCrLf & “Raghu Prabhu”
    MyAttachments.Add (Attachment)
    OutLookMailItem.Display
    OutLookMailItem.Send
    LastRow = LastRow + 1
    EmailAddress = “”
    x = x + 1
    Loop
    Set OutLookApp = Nothing
    Set OutLookMailItem = Nothing

    End Sub
    ‘5. Delete all the files created and emailed
    Sub del_xlsxFiles()
    Dim sPath As String
    sPath = ThisWorkbook.Path
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    Kill sPath & “\*.xlsx”
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    End Sub

    ‘6. delete column N and O in this worksheet
    Sub deleteColNthiswb()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Columns(“N:O”).Select
    Selection.Delete Shift:=xlToLeft
    Range(“A1”).Select
    ActiveWorkbook.Save
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    End Sub

  7. Dim mess_body As String, StrFile As String, StrPath As String
    Dim appOutLook As Outlook.Application
    Dim MailOutLook As Outlook.MailItem

    Set appOutLook = CreateObject(“Outlook.Application”)
    Set MailOutLook = appOutLook.CreateItem(olMailItem)

    ‘~~> Change path here
    StrPath = “H:\test\”

    With MailOutLook
    .BodyFormat = olFormatRichText
    .To = “test@test.org”
    .Subject = “test”
    .HTMLBody = “test”

    ‘~~> *.* for all files
    StrFile = Dir(StrPath & “*.*”)

    Do While Len(StrFile) > 0
    .Attachments.Add StrPath & StrFile
    StrFile = Dir
    Loop

    ‘.DeleteAfterSubmit = True
    .Send
    End With

    MsgBox “Reports have been sent”, vbOKOnly

  8. How to formula paste as value in this forma whic is i add below show debug plsease help me to make this thanks.
    ActiveSheet.Range(“A2:F4″).Copy
    Workbooks.Open Filename:=”C:\Users\suresh M\Desktop\copied-employee-data.xlsx”
    eColumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    If eColumn >= 1 Then eColumn = eColumn + 1
    ActiveSheet.Cells(1, eColumn).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, Skipblanks:=False, Transpose:=True
    Selection.PasteSpecial xlPasteValues
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    Application.CutCopyMode = False

  9. How to formula paste as value in this format which is i add below show debug please help me to how can use in value this thanks.
    ActiveSheet.Range(“A2:F4″).Copy
    Workbooks.Open Filename:=”C:\Users\suresh M\Desktop\copied-employee-data.xlsx”
    eColumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    If eColumn >= 1 Then eColumn = eColumn + 1
    ActiveSheet.Cells(1, eColumn).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, Skipblanks:=False, Transpose:=True
    Selection.PasteSpecial xlPasteValues
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    Application.CutCopyMode = False

Leave a Reply

Your email address will not be published. Required fields are marked *

This site uses Akismet to reduce spam. Learn how your comment data is processed.