Compiling data

[Finlay]

I am trying to compile data from various excel spreadsheets into one.
I want the data from a certian column in each sheet compiled in to one
column in my new sheet.

this is what I have so far

Sub TestFile3()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim Lc As Integer
Dim destrange As Range
Dim i As Long
Dim a As Integer
Dim lr As Integer
Application.ScreenUpdating = False
With Application.FileSearch
.NewSearch
.LookIn = "C:\bill"
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
lr = 1
If .Execute() > 0 Then
Set basebook = ThisWorkbook
cnum = 1
For i = 1 To .FoundFiles.Count
Set mybook = Workbooks.Open(.FoundFiles(i))
Set sourceRange = mybook.Worksheets(1).Columns("E:E")
a = sourceRange.Columns.Count

Set destrange = basebook.Worksheets(1).Cells(lr, 1)

sourceRange.Copy
destrange.PasteSpecial Paste:=xlAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False

lr = LastRow(basebook.Worksheets(1)) + 1

mybook.Close

Next i
End If
End With
Application.ScreenUpdating = True
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


My problem is after it opens up the second file, it copies the data
and then when it trys to past it I get an error, destination is not
the same as source

How can I get past this

Thanks in advance

 

[Ron de Bruin]

See the copy column Example
http://www.rondebruin.nl/copy3.htm

 

[Ron de Bruin]

Try this example

Sub TestFile()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim i As Long
Dim basebookLast As Long
Dim mybookLast As Long
Application.ScreenUpdating = False
With Application.FileSearch
.NewSearch
.LookIn = "C:\bill"
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
Set basebook = ThisWorkbook
rnum = 1
For i = 1 To .FoundFiles.Count
Set mybook = Workbooks.Open(.FoundFiles(i))

basebookLast = LastRow(basebook.Worksheets(1))
mybookLast = LastRow(mybook.Worksheets(1))
Set sourceRange = mybook.Worksheets(1).Range("E1:E" & mybookLast)
Set destrange = basebook.Worksheets(1).Cells(basebookLast + 1, 1)
sourceRange.Copy destrange
mybook.Close
Next i
End If
End With
Application.ScreenUpdating = True
End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

 

[Finlay]

Thanks for all your help

Try this example

Sub TestFile()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim i As Long
Dim basebookLast As Long
Dim mybookLast As Long
Application.ScreenUpdating = False
With Application.FileSearch
.NewSearch
.LookIn = "C:\bill"
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
Set basebook = ThisWorkbook
rnum = 1
For i = 1 To .FoundFiles.Count
Set mybook = Workbooks.Open(.FoundFiles(i))

basebookLast = LastRow(basebook.Worksheets(1))
mybookLast = LastRow(mybook.Worksheets(1))
Set sourceRange = mybook.Worksheets(1).Range("E1:E" & mybookLast)
Set destrange = basebook.Worksheets(1).Cells(basebookLast + 1, 1)
sourceRange.Copy destrange
mybook.Close
Next i
End If
End With
Application.ScreenUpdating = True
End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function