nathan2314
10-27-2010, 08:17 AM
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 basebook.Sheets("Sheet1").Range("A" & EndRow).Selection.PasteSpecial Paste:=xlPasteValues,Operation:=xlNone,SkipBlanks:=False, Transpose:=True
This is the full macro
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
Appreciate any Help!!
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 basebook.Sheets("Sheet1").Range("A" & EndRow).Selection.PasteSpecial Paste:=xlPasteValues,Operation:=xlNone,SkipBlanks:=False, Transpose:=True
This is the full macro
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
Appreciate any Help!!