Not Copying All Rows

[teresa]

I am writing code which
loops through the files in a folder,
points at sheet 1 of each file,
copies all the non-empty cells in column B of each sheet 1 (and the rows),
pastes this to consolidate worksheet.
MY CODE IS FINE - ONLY PROBLEM IS THAT ITS NOT COPYING ALL ROWS

Sub SubGetMyData3()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim owb As Workbook
Dim i, j As Long

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\My Documents\Career")
i = 1
j = 1
For Each objFile In objFolder.Files
If objFile.Type = "Microsoft Excel Worksheet" Then

Set owb = Workbooks.Open(Filename:=objFolder.Path & "\" &
objFile.Name)
owb.Worksheets("Sheet1").Cells(i, 2).EntireRow.Copy
Destination:=Worksheets("consolidate").Cells(j, 1)
i = owb.Worksheets("sheet1").Cells(Rows.Count, "A").Row + 1
j = Worksheets("consolidate").Cells(Rows.Count,
"A").End(xlUp).Row + 1
ActiveWorkbook.Close savechanges:=True
End If
Next
End Sub

 

[Dave Peterson]

Your code looks like it should only be copying the firstrow of those worksheets.

Sub SubGetMyData3()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim owb As Workbook
Dim j As Long
dim RngToCopy as range

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\My Documents\Career")

j = 1
For Each objFile In objFolder.Files
If objFile.Type = "Microsoft Excel Worksheet" Then
Set owb = Workbooks.Open(Filename:=objFolder.Path _
& "\" & objFile.Name)
with owb.Worksheets("Sheet1")
set rngtocopy = .range("b1:B" _
& .cells(.rows.count,"B").end(xlup).row)
end with

rngtocopy.entireRow.Copy _
Destination:=Worksheets("consolidate").Cells(j, 1)

j = Worksheets("consolidate") _
.Cells(Rows.Count, "A").End(xlUp).Row + 1
owb.Close savechanges:=false 'why true????
End If
Next objFile
End Sub

 

[Bob Phillips]

You don't give many clues do you?

Perhaps?

Sub SubGetMyData3()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim owb As Workbook
Dim i As Long, j As Long

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\My Documents\Career")
i = 1
j = 1
For Each objFile In objFolder.Files
If objFile.Type = "Microsoft Excel Worksheet" Then
Set owb = Workbooks.Open(Filename:=objFolder.Path & _
"\" & objFile.Name)
i = owb.Worksheets("sheet1").Cells(Rows.Count, "A").Row + 1
owb.Worksheets("Sheet1").Cells(1, 2).Resize(i, 1).EntireRow.Copy
_
Destination:=Worksheets("consolidate").Cells(j, 1)
j = Worksheets("consolidate").Cells(Rows.Count,
"A").End(xlUp).Row + 1
ActiveWorkbook.Close savechanges:=True
End If
Next
End Sub

--

HTH

RP
(remove nothere from the email address if mailing direct)