Compiling data

  • Thread starter Thread starter Finlay
  • Start date Start date
F

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
 
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
 
Thanks for all your help

Ron de Bruin said:
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
Click to expand...
 
Back
Top