copy contents of each Workbooks with Different data ranges from a Single Folder

[tyrese215]

Hi Everyone,

Here is my problem.... I have many workbooks in one folder that I would like to extract data from and dump into a consolidated workbook. Data that I want to extract begins on Row A7 to C7 from this source folder. This Data on Each workbook in this folder, however, has Different rows that the data range ends. eg some could finish on row 30 and some could finish on row 200.

I want to copy All of this range till the last record on each workbook in this source folder to my active workbook. This should be copied from row 7 on this destination workbook.

The copied data from each source workbook should be copied underneith eachother in my destination workbook.

I tried the following code but it fails to work... Can someone please help.. thank you





Sub xxxx()
Dim myDir As String, fn As String
myDir = "C:\xxx\Labor stuff\copy range code\Workbooks to copy\"
fn = Dir(myDir & "*.xls")
Do While fn <> ""
'If fn <> ThisWorkbook.Name Then
' For Each mySht In ActiveWorkbook.Sheets
' mySht.Unprotect Password:="xxx"
'Next

With Workbooks.Open(myDir & fn)

With .Sheets("Margin By Job Family - Perm").Range("a7:c" & .Cells(.Rows.Count, "a").End(xlUp))

ThisWorkbook.Sheets("merged").Range("a" & Rows.Count).End(xlUp)(2) _
.Resize(.Rows.Count, .Columns.Count).Value = .Value


End With
.Close False
End With

fn = Dir
Loop
End Sub

[MaximS]

Hi,

I think you can find solution here:

http://vbaexpress.com/kb/getarticle.php?kb_id=733

[tyrese215]

Hi... I do thank you for your time but this is not the solution that I am looking for. Please read my problem again. All I need is to copy each workbook data into a central repository on one sheet, All one under eachother..

Let me know if you can help me out..

I appreciate your time

[mdmackillop]

Option Explicit

Dim TgtRw As Long

Sub GetData()
Dim Foldr As String
Dim MyFile As String
Dim ThsSht As Worksheet
Dim Bk As Long
Application.ScreenUpdating = False

Set ThsSht = ActiveSheet
Foldr = "C:\AAA\"
MyFile = Dir(Foldr)
Bk = Bk + 1
Do
DoProcess Foldr & MyFile, ThsSht, Bk
MyFile = Dir
Bk = Bk + 1
Loop Until MyFile = ""
Application.ScreenUpdating = True
End Sub


Private Sub DoProcess(MyFile As String, ThsSht As Worksheet, Bk As Long)
Dim wb As Workbook
Dim ws As Worksheet
Dim Rw As Long, i As Long, x As Long

Set wb = Workbooks.Open(MyFile)
Set ws = wb.Sheets(1)
'get longest column
For i = 1 To 3
x = ws.Cells(Rows.Count, i).End(xlUp).Row
If x > Rw Then Rw = x - 6
Next
'Set paste location
If Bk = 1 Then
TgtRw = 7
Else
TgtRw = TgtRw + Rw
End If
Range("A7").Resize(Rw, 3).Copy ThsSht.Cells(TgtRw, 1)

wb.Close

End Sub