ExcelBanter - auto add column

ExcelBanter (https://www.excelbanter.com/)

- Excel Programming (https://www.excelbanter.com/excel-programming/)

- - auto add column (https://www.excelbanter.com/excel-programming/272172-auto-add-column.html)

Hi there,

i am hoping you can help.

i hav the following code (see below) which takes numbers from multiple
spreadsheets etc (and it works well) however i am trying to do 1 last thing
and that is as follows:

The number that is placed in cell (iRow, 6) i would like to have tallied at
the end of the script, so for instance if there are 70 numbers then i would
like to leave a space and have a tally appear just underneath it in Cell 'f'
Line 72. Is this easy to do?

Thanking you in advance

Scott

Sub SubGetMyData()
Application.ScreenUpdating = False

Dim objFSO As Scripting.FileSystemObject
Dim objFolder As Scripting.Folder
Dim objSubfolder As Scripting.Folder
Dim objFile As Scripting.File
Dim iRow As Long

iRow = 3
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("e:\scott\Sotek\Invoices\")
For Each objFile In objFolder.Files
If objFile.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open Filename:=objFolder.Path & "\" & objFile.Name
With ActiveWorkbook.Worksheets(1)
.Range("A13").Copy
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 1)
.Range("A14").Copy
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 2)
.Range("A15").Copy
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 3)
.Range("F7").Copy
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 4)
.Range("F8").Copy
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 5)
ThisWorkbook.Worksheets(1).Cells(iRow, 6).Value =
..Range("f45").Value
End With
ActiveWorkbook.Close savechanges:=False
iRow = iRow + 1
End If
Next

Application.ScreenUpdating = True
End Sub

How about:

Option Explicit
Sub SubGetMyData()
Application.ScreenUpdating = False

Dim objFSO As Scripting.FileSystemObject
Dim objFolder As Scripting.Folder
Dim objSubfolder As Scripting.Folder
Dim objFile As Scripting.File
Dim iRow As Long

iRow = 3
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Set objFolder = objFSO.getfolder("e:\scott\Sotek\Invoices\")
Set objFolder = objFSO.getfolder("C:\my documents\excel\test\")
For Each objFile In objFolder.Files
If objFile.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open Filename:=objFolder.Path & "\" & objFile.Name
With ActiveWorkbook.Worksheets(1)
.Range("A13").Copy _
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 1)
.Range("A14").Copy _
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 2)
.Range("A15").Copy _
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 3)
.Range("F7").Copy _
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 4)
.Range("F8").Copy _
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 5)
ThisWorkbook.Worksheets(1).Cells(iRow, 6).Value _
= .Range("f45").Value
End With
ActiveWorkbook.Close savechanges:=False
iRow = iRow + 1
End If
Next

With ThisWorkbook.Worksheets(1)
.Cells(iRow + 1, 6).Formula _
= "=sum(" & .Range(.Cells(3, 6), _
.Cells(iRow - 1, 6)).Address(0, 0) & ")"
End With

Application.ScreenUpdating = True
End Sub

I noticed that you changed that last copy (F45) to just an assignment. Just
curious: Is there some reason you didn't adjust the others, too?

ThisWorkbook.Worksheets(1).Cells(iRow, 1).value = .range("A13").value
(and so forth)

Scott wrote:

Hi there,

i am hoping you can help.

i hav the following code (see below) which takes numbers from multiple
spreadsheets etc (and it works well) however i am trying to do 1 last thing
and that is as follows:

The number that is placed in cell (iRow, 6) i would like to have tallied at
the end of the script, so for instance if there are 70 numbers then i would
like to leave a space and have a tally appear just underneath it in Cell 'f'
Line 72. Is this easy to do?

Thanking you in advance

Scott

Sub SubGetMyData()
Application.ScreenUpdating = False

Dim objFSO As Scripting.FileSystemObject
Dim objFolder As Scripting.Folder
Dim objSubfolder As Scripting.Folder
Dim objFile As Scripting.File
Dim iRow As Long

iRow = 3
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("e:\scott\Sotek\Invoices\")
For Each objFile In objFolder.Files
If objFile.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open Filename:=objFolder.Path & "\" & objFile.Name
With ActiveWorkbook.Worksheets(1)
.Range("A13").Copy
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 1)
.Range("A14").Copy
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 2)
.Range("A15").Copy
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 3)
.Range("F7").Copy
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 4)
.Range("F8").Copy
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 5)
ThisWorkbook.Worksheets(1).Cells(iRow, 6).Value =
.Range("f45").Value
End With
ActiveWorkbook.Close savechanges:=False
iRow = iRow + 1
End If
Next

Application.ScreenUpdating = True
End Sub

--

Dave Peterson

I'd guess that you dropped this line:

With ThisWorkbook.Worksheets(1)

But your formula looks fine to me. (Maybe even easier to understand!!!)

"Scott" wrote in message ...
Hi Dave,

tried your post but i couldn't get it work as it errored here ".Cells(3, 6)"
(invalid or unqualified reference), however i managed to bash it around to
this

ThisWorkbook.Worksheets(1).Cells(iRow + 1, 6) = "=Sum(F2:F" & (iRow - 1) &
")"

It's probably not the best coded but alas it works.
Thanks for your help it was greatly appreciated.

Regards

Scott

"Dave Peterson" wrote in message
...
How about:

Option Explicit
Sub SubGetMyData()
Application.ScreenUpdating = False

Dim objFSO As Scripting.FileSystemObject
Dim objFolder As Scripting.Folder
Dim objSubfolder As Scripting.Folder
Dim objFile As Scripting.File
Dim iRow As Long

iRow = 3
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Set objFolder = objFSO.getfolder("e:\scott\Sotek\Invoices\")
Set objFolder = objFSO.getfolder("C:\my documents\excel\test\")
For Each objFile In objFolder.Files
If objFile.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open Filename:=objFolder.Path & "\" & objFile.Name
With ActiveWorkbook.Worksheets(1)
.Range("A13").Copy _
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 1)
.Range("A14").Copy _
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 2)
.Range("A15").Copy _
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 3)
.Range("F7").Copy _
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 4)
.Range("F8").Copy _
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 5)
ThisWorkbook.Worksheets(1).Cells(iRow, 6).Value _
= .Range("f45").Value
End With
ActiveWorkbook.Close savechanges:=False
iRow = iRow + 1
End If
Next

With ThisWorkbook.Worksheets(1)
.Cells(iRow + 1, 6).Formula _
= "=sum(" & .Range(.Cells(3, 6), _
.Cells(iRow - 1, 6)).Address(0, 0) & ")"
End With

Application.ScreenUpdating = True
End Sub

I noticed that you changed that last copy (F45) to just an assignment.
Just
curious: Is there some reason you didn't adjust the others, too?

ThisWorkbook.Worksheets(1).Cells(iRow, 1).value = .range("A13").value
(and so forth)

Scott wrote:

Hi there,

i am hoping you can help.

i hav the following code (see below) which takes numbers from multiple
spreadsheets etc (and it works well) however i am trying to do 1 last
thing
and that is as follows:

The number that is placed in cell (iRow, 6) i would like to have tallied
at
the end of the script, so for instance if there are 70 numbers then i
would
like to leave a space and have a tally appear just underneath it in Cell
'f'
Line 72. Is this easy to do?

Thanking you in advance

Scott

Sub SubGetMyData()
Application.ScreenUpdating = False

Dim objFSO As Scripting.FileSystemObject
Dim objFolder As Scripting.Folder
Dim objSubfolder As Scripting.Folder
Dim objFile As Scripting.File
Dim iRow As Long

iRow = 3
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("e:\scott\Sotek\Invoices\")
For Each objFile In objFolder.Files
If objFile.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open Filename:=objFolder.Path & "\" & objFile.Name
With ActiveWorkbook.Worksheets(1)
.Range("A13").Copy
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 1)
.Range("A14").Copy
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 2)
.Range("A15").Copy
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 3)
.Range("F7").Copy
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 4)
.Range("F8").Copy
Destination:=ThisWorkbook.Worksheets(1).Cells(iRow , 5)
ThisWorkbook.Worksheets(1).Cells(iRow, 6).Value =
.Range("f45").Value
End With
ActiveWorkbook.Close savechanges:=False
iRow = iRow + 1
End If
Next

Application.ScreenUpdating = True
End Sub

--

Dave Peterson