Looping & Dumping
Teresa,
Hopefully, this is it
Option Explicit
Sub SubGetMyData3d()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim owb As Workbook
Dim j As Long
Dim RngToCopy As Range, Rng2ToCopy As Range
Dim intNumRows As Integer, c As Range, lngCellTotal As Long
Application.ScreenUpdating = False
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\MyTest\Proposals")
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("Proposals")
Set RngToCopy = .Range("B1:B" _
& .Cells(.Rows.Count,
"B").End(xlUp).Row)
End With
RngToCopy.EntireRow.Copy _
Destination:=ThisWorkbook.Worksheets("Proposals05" ).Cells(j, 1)
owb.Close savechanges:=False
j = ThisWorkbook.Worksheets("Proposals05") _
.Cells(Rows.Count, "B").End(xlUp).Row + 1
intNumRows = Cells(Rows.Count, "B").End(xlUp).Row
End If
Next objFile
With Worksheets("Proposals05").Range("B" & intNumRows + 1)
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Value = WorksheetFunction.Sum(Range("B1:B" & intNumRows))
End With
Application.ScreenUpdating = True
End Sub
--
HTH
RP
(remove nothere from the email address if mailing direct)
"teresa" wrote in message
...
My Objective: Loop through workbooks in a Folder, then point to
"Proposals"
worksheet in each workbook, then dump entries into "Proposals05" worksheet
in
current workbook.
The code works if
Proposals in 1st wks has "2"
Proposals in 2nd wks has "1"
Then proposals 05:
2
1
However, if:
Proposals in 1st wks has "2" and "122"
Proposals in 2nd wks has "1" and "111"
Then proposals 05:
2
1
111
instead of all 4 entries, my code below requires slight tweaking, any help
is appreciated
Sub SubGetMyData3d()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim owb As Workbook
Dim j As Long
Dim RngToCopy, Rng2ToCopy As Range
Dim intNumRows As Integer, c As Range, lngCellTotal As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\My Documents\Career")
j = 1: k = 1: l = 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("Proposals")
Set RngToCopy = .Range("B1:B" _
& .Cells(.Rows.Count, "B").End(xlUp).Row)
End With
RngToCopy.EntireRow.Copy _
Destination:=Worksheets("Proposals05").Cells(j, 1)
j = Worksheets("Proposals05") _
.Cells(Rows.Count, "A").End(xlUp).Row + 1
intNumRows = Cells(50, "B").End(xlUp).Row
End If
Next objFile
For Each c In Worksheets("Proposals05").Range("B1:B" & intNumRows)
lngCellTotal = lngCellTotal + c.Value
Next
'With Worksheets("Proposals05").Range("B" & intNumRows + 1)
' .Borders(xlEdgeLeft).Weight = xlMedium
' .Borders(xlEdgeTop).Weight = xlMedium
' .Value = lngCellTotal
'End With
End Sub
|