Solved: Copying data from one workbook and then transposing and pasting to another workbook

[nathan2314]

Hello,

I'm trying to piece together some VBA code that will go through a folder and open all .xls files, copy a certain range (the data is in a column), and paste it in a master .xls file transposed (so each column in the data .xls files would become rows in the master). As each data .xls is opened and the data copied, I want it to be copied to the next open row in the master. I've figured out how to go through each .xls file in a folder, open it, and select the data. How do I transpose it to the masterexcel file ??
Also, the sheet name in all the .xls files in the folder are all the same. Also, the data is in the same range for each .xls data files. Also, the part where I need to append to the master file at the next blank row is also working. The part that is not is [VBA] basebook.Sheets("Sheet1").Range("A" & EndRow).Selection.PasteSpecial Paste:=xlPasteValues,Operation:=xlNone,SkipBlanks:=False, Transpose:=True
[/VBA]

This is the full macro
[VBA]Sub ExtractData()
Dim basebook As Workbook
Dim mybook As Workbook
Dim FNames As String
Dim MyPath As String
Dim MyCompletePath As String
Dim SaveDriveDir As String
Dim Cnum As Integer

MyCompletePath = ActiveWorkbook.FullName
MyPath = ActiveWorkbook.Path
SaveDriveDir = MyPath

'MyPath = "C:\Alice Wong\Responses\Submission"
'file path
ChDrive MyPath
ChDir MyPath
FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
'clear all cells on the first sheet
basebook.Sheets("Sheet1").Cells.Clear
Do While FNames <> ""
If FNames <> "MasterCompile.xls" Then
Set mybook = Workbooks.Open(FNames)
' Get Row number to Copy new data to
EndRow = basebook.Sheets("Sheet1").Cells(65536, 1).End(xlUp).Row+1
' Select the current data area.
mybook.Sheets("sheets1").Range("A1:A8").Select

basebook.Sheets("Sheet1").Range("A" & EndRow).Selection.PasteSpecial Paste:=xlPasteValues,Operation:=xlNone,SkipBlanks:=False, Transpose:=True

Application.CutCopyMode = False
mybook.Close False
End If
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
basebook.Save
End Sub
[/VBA]


Appreciate any Help!!

[Ryan Remole]

[VBA]
'This is alternate code for inside your loop besides copy&paste.
Sub MoveData()

Dim var1(0 To 5000)
Dim wb As Workbook

Application.Calculation = xlCalculationManual 'highly recommend!
Application.ScreenUpdating = False

For Each wb In Workbooks
If ThisWorkbook.Name <> wb.Name Then '<-Obviously, you can use your code here for the loop.

wb.Activate
For var2 = 0 To 5000
If var2 > Sheets("Sheet2").UsedRange.Rows.Count Then Exit For
'I actually still like the "UsedRange".
'Yes, it kills the "undo" option, but I'm guessing this program is for you.
var1(var2) = Sheets("Sheet2").Range("A1").Offset(var2, 0).Value
Next

For var3 = 0 To var2
Sheet1.Range("A1").Offset(var4, var3).Value = var1(var3)
var1(var3) = Empty
Next
var4 = var4 + 1

End If
Next

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub


[/VBA]

[nathan2314]

Thanks You!
It worked