Iam using the following code to copy values between workbooks, the question is, is there any way that instead of copying the information of each workbook down through rows it is copied by columns detecting the last empty one column?
Sub ()
Dim xRg As Range
Dim xSelItem As Variant
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook As Workbook
Dim xSheet As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Hoja1" 'HOJA DONDE VA A COPIAR LA INFO
xRgStr = "G7:IV12" 'RANGO DE QUE VA A COPIAR
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
With xFileDlg
If .Show = -1 Then
xSelItem = .SelectedItems.Item(1)
Set xWorkBook = ThisWorkbook
Set xSheet = xWorkBook.Sheets("New Sheet")
xFileName = Dir(xSelItem & "\*.xls", vbNormal)
If xFileName = "" Then Exit Sub
Do Until xFileName = ""
Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy
xSheet.Range("A65536").End(xlUp).Offset(0, 0).Resize(xRg.Rows.Count, xRg.Columns.Count).Value = xRg.Value
xFileName = Dir()
xBook.Close
Loop
End If
End With
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
For example (numbers are examples of data to be copy from each workbook):
Workbook1: 1 2
Workbook2: 3 4
Workbook3: 5 6
NewSheet:
1 2
3 4
5 6
What I want NewSheet:
123456
Sub ()
Dim xRg As Range
Dim xSelItem As Variant
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook As Workbook
Dim xSheet As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Hoja1" 'HOJA DONDE VA A COPIAR LA INFO
xRgStr = "G7:IV12" 'RANGO DE QUE VA A COPIAR
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
With xFileDlg
If .Show = -1 Then
xSelItem = .SelectedItems.Item(1)
Set xWorkBook = ThisWorkbook
Set xSheet = xWorkBook.Sheets("New Sheet")
xFileName = Dir(xSelItem & "\*.xls", vbNormal)
If xFileName = "" Then Exit Sub
Do Until xFileName = ""
Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy
xSheet.Range("A65536").End(xlUp).Offset(0, 0).Resize(xRg.Rows.Count, xRg.Columns.Count).Value = xRg.Value
xFileName = Dir()
xBook.Close
Loop
End If
End With
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
For example (numbers are examples of data to be copy from each workbook):
Workbook1: 1 2
Workbook2: 3 4
Workbook3: 5 6
NewSheet:
1 2
3 4
5 6
What I want NewSheet:
123456