VBA to import and transpose multiple sheets data - vba

Question

I have been working on the below code, however I am looking to edit this further:
1) Instead of setting 'Set Range1' via an input box, this should always be the cell range of 'B2:P65' when looping through the sheets in the folder.
2) When pasting the data I want this to fill starting at column B of the 'Database' tab in the workbook and then subsequently C, D, E etc.. for the rest of the workbooks in the folder loop.
Sub LoopFileUpload_base()
Dim wb As Workbook
Dim myPath As String
Dim myfile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim Range1 As Range, Range2 As Range, Rng As Range
Dim rowIndex As Integer
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
myExtension = "*.xlsx"
myfile = Dir(myPath & myExtension)
Do While myfile <> ""
Set wb = Workbooks.Open(fileName:=myPath & myfile)
'CHANGE CODE BELOW HERE
xTitleId = "Range"
Set Range1 = Application.Selection
Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
rowIndex = 0
For Each Rng In Range1.Rows
Rng.Copy
Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
rowIndex = rowIndex + Rng.Columns.Count
Next
'CHANGE CODE ABOVE HERE
wb.Close SaveChanges:=True
myfile = Dir
Loop
MsgBox "Task Complete!"
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Answer 1

Consider the following macro where you loop through .xlsx workbooks in a folder and iteratively copy cells in specified range to current sheet row by row. Then, after each workbook move to next column:
Sub TransposeWorkbooks()
Dim strfile As String
Dim sourcewb As Workbook
Dim i As Integer, j As Integer
Dim cell As Range
strfile = Dir("C:\Path\To\Workbooks\*.xlsx")
ThisWorkbook.Sheets("Database").Activate
ThisWorkbook.Sheets("Database").Range("A2").Activate
Do While Len(strfile) > 0
' OPEN SOURCE WORKBOOK
Set sourcewb = Workbooks.Open("C:\Path\To\Workbooks\" & strfile)
ThisWorkbook.Activate
ActiveCell.Offset(0, 1).Activate ' MOVE TO NEXT COLUMN
ActiveCell = strfile
' ITERATE THROUGH EACH CELL ACROSS RANGE
j = 1
For Each cell In sourcewb.Sheets(1).Range("B2:P65")
ActiveCell.Offset(j, 0).Value = cell.Value ' MOVE TO NEXT ROW
j = j + 1
Next cell
' CLOSE WORKBOOK
sourcewb.Close False
strfile = Dir
Loop
End Sub

Answer 2

It sounds like you got your task solved. For future reference, please try the AddIn from the link below. I think you will find so many uses for this tool.
http://www.rondebruin.nl/win/addins/rdbmerge.htm