If you want to transpose use PasteSpeial with the last argument True

sourceRange.Copy
destrange.PasteSpecial xlPasteValues, , False, True
Application.CutCopyMode = False

And change rnum = rnum + SourceRcount to
rnum = rnum + 1

You can delete
SourceRcount = sourceRange.Rows.Count

If you need more help post back



--
Regards Ron De Bruin
http://www.rondebruin.nl



"IntricateFool" <IntricateFool@discussions.microsoft.com> wrote in message
news:F4FD1C11-C1CB-46D6-913B-D8B14FADD596@microsoft.com...
>I finally figured out a way to extract data from all workbooks contained in
> one folder. The data being extracted is composed in one column (column b x 26
> rows), extracted from 50 files (one for each state). I need this data to be
> put into a basebook as rows (transposed) so that for each state abbreviation,
> all data will appear to the right of the state (the first row of column b is
> the state abbreviation) . I know there is a way to pull in the data so that
> it is showing 26 columns with all the data placed directly under these
> columns (so 50 rows will be shown, one for each state). I just don't know how
> to manipulate the vba accordingly.
>
> As of now, it just pulls everything one block at a time, and now I have
> 50x26 rows...
> Here is how I am pulling the data now:
>
> Sub Example1()
> Dim basebook As Workbook
> Dim mybook As Workbook
> Dim sourceRange As Range
> Dim destrange As Range
> Dim rnum As Long
> Dim SourceRcount As Long
> Dim FNames As String
> Dim MyPath As String
> Dim SaveDriveDir As String
>
> SaveDriveDir = CurDir
> MyPath = "C:\!Data\Data Collection"
> 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
> basebook.Worksheets("Sheet1").Cells.Clear
>
> rnum = 1
>
> Do While FNames <> ""
> Set mybook = Workbooks.Open(FNames, Password:="chris",
> WriteResPassword:="chris", UpdateLinks:=0)
> Set sourceRange = mybook.Worksheets("Please Complete
> (Medical)").Range("C6:C31")
> SourceRcount = sourceRange.Rows.Count
> Set destrange = basebook.Worksheets("Sheet1").Cells(rnum, "A")
>
> basebook.Worksheets("Sheet1").Cells(rnum, "D").Value = mybook.Name
>
> sourceRange.Copy destrange
>
> mybook.Close False
> rnum = rnum + SourceRcount
> FNames = Dir()
> Loop
> ChDrive SaveDriveDir
> ChDir SaveDriveDir
> Application.ScreenUpdating = True
> End Sub
>
> Need only 50 rows.
> Someone please help...!
>