Looping & Dumping

[Guest]

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

 

[Bob Phillips]

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)

 

[Guest]

Hi, thats great - thanks so much and have a great new Year