CODEWITHSUNDEEP
vbaexcel
Caras
Caras

Reputation: 15

Copy specific range to first available row in another worksheet and transpose

The code below runs smoothly, and copies the data from Workbook1 to Workbook2 on the first available row, starting from column B. I need to know when the data was submitted, and therefore want the time and date to be inserted into the first available cell in column A each time data is submtited. Thanks for your help!

Option Explicit

Sub MoveData()

'Define variables
Dim Workbook1 As Workbook
Dim Workbook2 As Workbook
Dim wb As Workbook
Dim ws As Worksheet
Dim LastRow As Long, DestLastRow As Long

'Set wb
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")

'Copy (In this case I want to copy range D4:D7 only, and this will be the same every time)
ThisWorkbook.Sheets("Sheet1").Range("D4:D7").Copy

'Open Workbook 2 and paste data (transposed) on first available row starting in column B
Set Workbook2 = Workbooks.Open("H:\Macro FSC\Forsøk10\Workbook2.xlsm")
With Workbook2.Sheets("Sheet1")
    ' find last row with data in destination workbook "Workbook2.xlsm"
    DestLastRow = .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Row
     'paste special only values, and transpose
    .Range("B" & DestLastRow).PasteSpecial xlValues, Transpose:=True
End With

'Save and close
Workbook2.Save
Workbook2.Close

End Sub

Upvotes: 1

Views: 544

Answers (1)

Preston
Preston

Reputation: 8187

Try this, it's a one line solution

Option Explicit

Sub MoveData()

'Define variables
Dim Workbook1 As Workbook
Dim Workbook2 As Workbook
Dim wb As Workbook
Dim ws As Worksheet
Dim LastRow As Long, DestLastRow As Long

'Set wb
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")

'Copy (In this case I want to copy range D4:D7 only, and this will be the same every time)
ThisWorkbook.Sheets("Sheet1").Range("D4:D7").Copy

'Open Workbook 2 and paste data (transposed) on first available row starting in column B
Set Workbook2 = Workbooks.Open("H:\Macro FSC\Forsøk10\Workbook2.xlsm")
With Workbook2.Sheets("Sheet1")
    ' find last row with data in destination workbook "wbDatabase.xlsm"
    DestLastRow = .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Row
     'paste special only values, and transpose
    .Range("B" & DestLastRow).PasteSpecial xlValues, Transpose:=True
'Added line here:
    .range("A1").Value = now
End With

'Save and close
Workbook2.Save
Workbook2.Close

End Sub

Upvotes: 1

Related Questions