Summing

[teresa]

The code looks through files ina folder and then dumps the figures in a
worksheet,
then at bottom sums cells, the looping & dumping works fine,
doesn't seem to sum, help is much appreciated, thanks

Sub SubGetMyData3c()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim owb As Workbook
Dim j, k As Long
Dim RngToCopy, Rng2ToCopy As Range
Dim intNumRows As Integer, c As Variant, 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
With Range("b" & intNumRows + 1)
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium

End With
For Each c In Range("b1", "b" & intNumRows)
lngCellTotal = lngCellTotal + c.Value
Next
Range("b" & intNumRows + 1) = lngCellTotal
End If
Next objFile
End Sub

 

[Bob Phillips]

Sub SubGetMyData3c()
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

--

HTH

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

 

[teresa]

Thanks A million Bob

Sub SubGetMyData3c()
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

--

HTH

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

 

[Bob Phillips]

Is it all working now? It's been a long journey

Bob

 

[teresa]

Bob, not quite - but we're getting there

Is it all working now? It's been a long journey

Bob