Solved: Compile all xls file column by column

[slamet Harto]

Hi there,

Can you help to modify the following code if i want to combine all the xls file into 1 file column to column.
example: if file A has 100 row in column A1 to D100 then File B will be copied into Column E1 to H100 and so on. However, if sheet target has reached column IV then will create a new sheet to paste the data.

Many thanks in advance.

Sub CompileData()
Dim uRng As Range,Pth As String, tgt
Dim Sht As Worksheet, TgtSht as Worksheet
Dim i As Long
Dim wb As Workbook, MyBk As Workbook

Application.ScreenUpdating = False
Set MyBk = ActiveWorkbook
Set Sht = MyBk.Sheets("Sheet1")
Set tgt = MyBk.Sheets("Sheet2").Cells(1, 1)

Pth = "d:\My Documents\New Folder\"
For i = 1 To 45

If Sht.Cells(i, 1) <> "" Then
Set wb = Workbooks.Open(Pth & Sht.Cells(i, 1).Text)
wb.Sheets(Sht.Cells(i, 2).Text).UsedRange.Copy tgt
wb.Close False
Set uRng = MyBk.Sheets("Sheet2").UsedRange
Set tgt = uRng.Offset(uRng.Rows.Count + 1)(1)
End If


Next
Application.ScreenUpdating = True
End Sub

[fb7894]

Are you familiar with the UsedRange property? I think that will help.

In your example, the address of FileA.UsedRange is a1:d100.
When you set your target, use the offset. Like this.

Set tgt = FileA.UsedRange.Offset(FileA.UsedRange.Columns.Count)


Make sense?

[hardlife]

Sub CompileDataDown()
Dim uRng As Range, Pth As String, tgt
Dim Sht As Worksheet, TgtSht As Worksheet
Dim i As Long
Dim wb As Workbook, MyBk As Workbook

Application.ScreenUpdating = False
Set MyBk = ActiveWorkbook
Set Sht = MyBk.Sheets(1)
Set tgt = MyBk.Sheets(2).Cells(1, 1)
'Set tgt = MyBk.Sheets(2).UsedRange.Offset(MyBk.Sheets(2).UsedRange.Columns.Count)

Sheets(2).Cells.Clear

'MsgBox ThisWorkbook.path & Application.PathSeparator
Pth = "d:\My Documents\New Folder\"
'Pth = ThisWorkbook.path & Application.PathSeparator

For i = 1 To 2

'If Sht.Cells(i, 1) <> "" Then
'Set wb = Workbooks.Open(Pth & Sht.Cells(i, 1).Text)
Set wb = Workbooks.Open(Pth & i & ".xls")
'MsgBox Pth & i & ".xls"
'wb.Sheets(Sht.Cells(i, 2).Text).UsedRange.Copy tgt
wb.Sheets(1).UsedRange.Copy tgt
wb.Close False
Set uRng = MyBk.Sheets(2).UsedRange
'Set tgt = uRng.Offset(uRng.Rows.Count + 1)(1) 'skip 1 line before new data
Set tgt = uRng.Offset(uRng.Rows.Count)(1)
'MsgBox (uRng.Rows.Count)
'End If

Next
Application.ScreenUpdating = True
End Sub

Sub CompileDataRight()
Dim uRng As Range, Pth As String, tgt
Dim Sht As Worksheet, TgtSht As Worksheet
Dim i As Long
Dim wb As Workbook, MyBk As Workbook

Application.ScreenUpdating = False
Set MyBk = ActiveWorkbook
Set Sht = MyBk.Sheets(1)
Set tgt = MyBk.Sheets(2).Cells(1, 1)

Sheets(2).Cells.Clear

'MsgBox ThisWorkbook.path & Application.PathSeparator
Pth = "d:\My Documents\New Folder\"
'Pth = ThisWorkbook.path & Application.PathSeparator

For i = 1 To 2

'If Sht.Cells(i, 1) <> "" Then
'Set wb = Workbooks.Open(Pth & Sht.Cells(i, 1).Text)
Set wb = Workbooks.Open(Pth & i & ".xls")
'MsgBox Pth & i & ".xls"
'wb.Sheets(Sht.Cells(i, 2).Text).UsedRange.Copy tgt
wb.Sheets(1).UsedRange.Copy tgt
wb.Close False
Set uRng = MyBk.Sheets(2).UsedRange
Set tgt = MyBk.Sheets(2).UsedRange.Offset(0, MyBk.Sheets(2).UsedRange.Columns.Count)
'MsgBox (uRng.Columns.Count)
'End If

Next
Application.ScreenUpdating = True
End Sub


hope this will help You, good luck

Pavel Humenuk

[slamet Harto]

Thanks Pavel,

I still have an issue for CompileDataRight code, when go to this I see the data is still overlaping.
Example: FILE A is copied into the target sheet (column A to D), also for FILE B where copied into column E to H , but File C is copy to the same column with File B.

I will go back to your code to realign it. Thanks for the tips.
Rgds, Harto

[hardlife]

Sub CompileDataRight()
Dim uRng As Range, Pth As String, tgt
Dim Sht As Worksheet, TgtSht As Worksheet
Dim i As Long
Dim wb As Workbook, MyBk As Workbook

Application.ScreenUpdating = False
Set MyBk = ActiveWorkbook
Set Sht = MyBk.Sheets(1)
Set tgt = MyBk.Sheets(2).Cells(1, 1)

Sheets(2).Cells.Clear

'MsgBox ThisWorkbook.path & Application.PathSeparator
Pth = "d:\My Documents\New Folder\"
'Pth = ThisWorkbook.path & Application.PathSeparator

For i = 1 To 4

'If Sht.Cells(i, 1) <> "" Then
'Set wb = Workbooks.Open(Pth & Sht.Cells(i, 1).Text)
Set wb = Workbooks.Open(Pth & i & ".xls")
'MsgBox Pth & i & ".xls"
'wb.Sheets(Sht.Cells(i, 2).Text).UsedRange.Copy tgt
wb.Sheets(1).UsedRange.Copy tgt
wb.Close False
Set uRng = MyBk.Sheets(2).UsedRange
'Set tgt = MyBk.Sheets(2).UsedRange.Offset(0, MyBk.Sheets(2).UsedRange.Columns.Count)
Set tgt = MyBk.Sheets(2).Range(MyBk.Sheets(2).Cells(1, MyBk.Sheets(2).UsedRange.Columns.Count + 1).Address)
MsgBox MyBk.Sheets(2).Cells(1, MyBk.Sheets(2).UsedRange.Columns.Count + 1).Address

'MsgBox (uRng.Columns.Count)
'End If

Next
Application.ScreenUpdating = True
End Sub


Hi Harto, You are right there was mistake, sorry for that.

hope this will help You, good luck and happy day :hi:
Pavel Humenuk

[slamet Harto]

Hi Pavel, thanks for response. highly appreciate it.

This is what i've done so far.

Public Sub CombineAll()
Dim sTarget As String, shtTarget As Worksheet, lColTarget As Long, lOffset As Long, lColMax As Long
Dim rngFiles As Range, rngFile As Range, sFile As String, sPath As String
Dim lFile As Long, rngData As Range, sPos As String, lCol As Long, sStatusBar As String

With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
End With
sStatusBar = Application.StatusBar
sTarget = ThisWorkbook.Name
lFile = Worksheets("Sheet1").Range("b2").CurrentRegion.Rows.Count - 1
Set rngFiles = Workbooks(sTarget).Worksheets("Sheet1").Range("b2").Offset(1).Resize(lFile, 1)
Set shtTarget = Workbooks(sTarget).Worksheets(Sheets.Count)
lColMax = shtTarget.Range("a1").EntireRow.Columns.Count
lColTarget = shtTarget.Range("a1").SpecialCells(xlCellTypeLastCell).Column
If lColTarget = 1 Then
lColTarget = 0
lOffset = 0
Else
lOffset = 1
End If

For Each rngFile In rngFiles
sPath = Trim$(rngFile.Offset(0, 3))
sFile = Trim$(rngFile) & ".xls"
If LenB(sPath) <> 0 Then
If Right$(Trim$(sPath), 1) <> "\" Then
sPath = sPath & "\"
End If

If LenB(sFile) <> 0 Then
If LenB(Dir$(sPath & sFile)) <> 0 Then
Workbooks.Open sPath & sFile
Workbooks(sFile).Activate
With Worksheets(1)
sPos = .Range("b1").End(xlDown).Address
lCol = .Range(sPos).CurrentRegion.Columns.Count
If lColTarget + lCol < lColMax Then
lColTarget = lColTarget + lCol
Else
Workbooks(sTarget).Activate
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "NewSheet" & Sheets.Count
Set shtTarget = Workbooks(sTarget).Worksheets(Workbooks(sTarget).Sheets.Count)
lColTarget = lCol
lOffset = 0
Workbooks(sFile).Activate
Sheets(1).Select
End If
.Range(sPos).CurrentRegion.EntireColumn.Copy
shtTarget.Range("a1").SpecialCells(xlCellTypeLastCell).Offset(0, lOffset).End(xlUp).PasteSpecial (xlPasteValues)
If lOffset <> 1 Then
lOffset = 1
End If
End With
Workbooks(sFile).Close False
Application.StatusBar = "File : " & rngFile.Row - 1 & " of " & lFile
End If
End If
End If
Next
With Application
.StatusBar = sStatusBar
.DisplayAlerts = True
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Finished", vbInformation
End Sub

[hardlife]

Hi Harto, me is happy to see Your code is working,
it was no easy, hard work, good luck :hi: Pavel