To extract content fo cells from many workbokks which are identica

[Frank Situmorang]

Hello,

My VBA below is to extract the information from each individual workbook and
cosolidate it

But now I want to take just the content of the cells ( formula result) and
summarize it in a consolidated workbook.

More or less the problem is below:
To make it clear, more or less this is the outlay:

A B C D
1
2
3
4
5
6

I just want to pull out the content of the cells and I want to make a
summary for all:

cell to pull out:

A1 ( Job Number)
A2 ( Proj. Mgr)
A6 (Total Budget)
D6 ( Total Costs)

...and other cells that I want to pull out the information and summarize it

in my sreadsheet to be sideway:
Job NO. Proj. Mgr total Budget Total actual........
---- --------- ------------ -------------
xx xxx xxxx xxx
xxx xxxx xxxx xxx

The second problem how can I change the getopen that takes file with
selection, with get open but we predetermine the workbook to retrieve, since
there are a lot of workbooks>

Below is my macro, which runs ok with copying from workingsheet.
Sub FrankS2()
Application.ScreenUpdating = False
Dim wbCurrent As Workbook, wbConsolidate As Workbook
files_to_open = _
Application.GetOpenFilename("Excel files (*.xls), _*.xls", , , , True)
If Not IsArray(files_to_open) Then
MsgBox "Nothing selected"
Exit Sub
Else
'Setup new workbook to receive all data
Set wbConsolidate = Workbooks.Add

For i = LBound(files_to_open) To UBound(files_to_open)
Set wbCurrent = Workbooks.Open(files_to_open(i))
Application.StatusBar = "Processing " & files_to_open(i)
FrankctoValue3 wbCurrent, wbConsolidate
wbCurrent.Close
Next i

With wbConsolidate.Sheets(1)
'delete top row if A1 blank:
If .Range("A1") = "" Then .Range("A1").EntireRow.Delete

'Sort
.Cells.Sort Key1:=.Range("A1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

'adjust column widths
.Cells.EntireColumn.AutoFit
End With

NewFileName = "Consolidated " & Format(Date, "yyyy mmm d") & " at " &
Format(Time, "hh mm")
wbConsolidate.SaveAs NewFileName
wbConsolidate.Close
End If
Set wbCurrent = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox UBound(files_to_open) - LBound(files_to_open) + _
1 & " files processed (hopefully), named:" & vbLf & NewFileName
End Sub
Sub FrankctoValue3(myWb As Workbook, ConsolWb As Workbook)
Set ToWs = ConsolWb.Sheets(1)
ToWs.Name = "interface" 'adjust name of sheet here
Set FromWs = myWb.Worksheets("PO New")
HowManyColumnsToCopy = 40 'the number of columns you want copying across

'This section takes all cells in Column AW with a formula, a string or a
value in, and processes ONLY those rows
'Range_NonBlanks(Columns("AW")).Select

For Each cll In Range_NonBlanks(FromWs.Columns("AW"))
'Union(FromWs.Columns("AW").SpecialCells(xlCellTypeFormulas, 23),
FromWs.Columns("AW").SpecialCells(xlCellTypeConstants, 23))
If cll.Value <> "" Then
Range(cll, cll.Offset(0, HowManyColumnsToCopy - 1)).Copy
ToWs.Range("A" & ToWs.Rows.Count).End(xlUp).Offset(1,
0).PasteSpecial Paste:=xlPasteValues
End If
Next cll


'This section tidies up: deletes top row if empty, sorts, and adjusts column
widths
'comment out the next 5 lines to prevent deletion of all but the new sheet
Application.DisplayAlerts = False
End Sub


Thanks for any help.

Frank