new macro

[Scott]

Hi There,

I have a macro ('GetMyData' see below for code) that goes through a
directory and pulls all relevant details from different excel spreadsheets
and copies the data into 1 spreadsheet call 'totalling'.

i now wish to try and create a new spreadsheet 'statement' which will
collect some info from the spreadsheet called 'totalling' and copy data back
into 'statement'

i am lost on several points and these are as follows:

the field in column 'A' on 'totalling' lists a company name and then fields
b etc contain info about 'A' i want to copy cells 'E' 'F' 'G' into
'statement' and do that for as long as 'A' contains that company name.

any assitance is greatly appreciated, and i would like to thank you all in
advance for any help given.

Regards,

Scott


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

With ThisWorkbook.Worksheets(1).Range("A1:G1")
.Value = Array("Name", "Contact", "Address", "Suburb", "Date",
"Number", "Amount")
With .Font
.Name = "Arial"
.Size = 16
.Bold = True
End With
.HorizontalAlignment = xlCenter
End With

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("d:\files\spreadsheets\")
For Each objFile In objFolder.Files
If objFile.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open Filename:=objFolder.Path & "\" & objFile.Name
With ActiveWorkbook.Worksheets(1)
ThisWorkbook.Worksheets(1).Cells(iRow, 1).Value =
..Range("A13").Value
ThisWorkbook.Worksheets(1).Cells(iRow, 2).Value =
..Range("A14").Value
ThisWorkbook.Worksheets(1).Cells(iRow, 3).Value =
..Range("A16").Value
ThisWorkbook.Worksheets(1).Cells(iRow, 4).Value =
..Range("A17").Value
ThisWorkbook.Worksheets(1).Cells(iRow, 5).Value =
..Range("F7").Value
ThisWorkbook.Worksheets(1).Cells(iRow, 6).Value =
..Range("F8").Value
ThisWorkbook.Worksheets(1).Cells(iRow, 7).Value =
..Range("F45").Value
End With
ActiveWorkbook.Close savechanges:=False
iRow = iRow + 1
End If
Next

ThisWorkbook.Worksheets(1).Cells(iRow + 1, 7) = "=Sum(G2:G" & (iRow - 1)
& ")"
ThisWorkbook.Worksheets(1).Cells(iRow + 1, 6) = "TOTAL"

ThisWorkbook.Worksheets(1).Cells(iRow + 1, 6).Select
Selection.Font.Bold = True
With Selection.Font
.Name = "Arial"
.Size = 14
End With

ThisWorkbook.Worksheets(1).Cells(iRow + 1, 7).Select
Selection.Font.Bold = True
With Selection.Font
.Name = "Arial"
.Size = 14
End With
Selection.Style = "Currency"

With ThisWorkbook.Worksheets(1).Range("A1:G1").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
End With

ThisWorkbook.Worksheets(1).Columns("A:G").EntireColumn.AutoFit

Range("A3").Select
Range("A3:G68").Sort Key1:=Range("A3"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Application.ScreenUpdating = True

End Sub

 

[BrianB]

Without checking your code, a basic method is to use 2 nested
While..wend loops to control the process as follows. A quick way to
continue would be to copy this to the top of your module. It uses your
routine as a sub. Obviously some adjustments will be needed to the
original. I generally find that using Copy/Paste Special runs a lot
faster - especially when formatting cells.:-

'---------------------------------------------------
Sub test()
iRow = 1 ' set start row
'-----------------------
'- run through all data
'-----------------------
While ActiveSheet.Cells(iRow, 1).Value <> ""
company = ActiveSheet.Cells(iRow, 1).Value
'--------------------------
'- run through company data
'--------------------------
While ActiveSheet.Cells(iRow, 1).Value = company
GetMyData ' run original routine
iRow = iRow + 1
Wend
Wend
End Sub
'------------------------------------------------------