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
How to copy data, paste it in another workbook while transposing the pasted data using VBA.
Do you have the VBA code using Rows instead of columns
https://www.exceltrainingvideos.com/copy-data-paste-another-workbook-transpose-automatically-using-excel-vba/
Have a look at this link: https://www.exceltrainingvideos.com/copy-paste-multiple-rows-of-data-from-one-workbook-to-another-using-excel-vba/
There are many more such examples using rows instead of columns.
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.
Sirji I work on cash collection counter need cash denomination control system by using Excel for avoid difference in cash with count transaction
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.
how to open excel open password if we forgot. i lost my password excel open.(.xls – format)
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
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
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.
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
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 = “[email protected]”
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
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 = “[email protected]”
.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
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
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
how to transpose column data to row but in another workbook? can you plz give me the code for it. thanks