to pull out information from certain cells of hundred identical wo

[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

 

[Ron de Bruin]

See this code example that will create the links for you
http://www.rondebruin.nl/summary2.htm

Or use my Merge add-in to do it (no formulas then but values)
http://www.rondebruin.nl/merge.htm



--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

 

[Frank Situmorang]

Thanks Ron for your help. I appreciate it if you still can help me on how can
we change getopenfile into the list of files, because I have about 300 files
to select in 2 directory.

The following is my modified VBA:
Sub RoundedRectangle1_Click()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "SUMMARY" '<---- Change
Set Rng =
Range("c7,C8,E7,d114,h4,d59,e59,d66,f66,d73,F73,D102,F95,D103,D104")
'<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName
& "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(,
, xlR1C1))
If Err.Number <> 0 Then
'If the sheet not exist in the workbook the row color will
be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If

End Sub

Thanks very much,

Frank

 

[Frank Situmorang]

Ron,

I think example 1 is ok for me, but how if the workbook requests for the
password to kein in. What should we change in the VBA

Thanks very much.

Frank

 

[Ron de Bruin]

Try the add-in
http://www.rondebruin.nl/merge.htm

You can use subfolders there and have a password option


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

 

[Frank Situmorang]

Hello Ron,

Thanks for your response.

Below is my modifed code. I do not know how to modify th VBA, if all the
workbooks that want to be linked have the same password. I run your below
code and for each workbook prompt us to fill in the password, and when I
enter the password, it can not run even stucked there alwasy request the
password for the same workbook.

Sub Rectangle1_Click()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "SUMMARY" '<---- Change
Set Rng =
Range("C7,C8,E7,D114,H4,D59,E59,D66,F66,D73,F73,D102,F95,D103,D104")
'<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName
& "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(,
, xlR1C1))
If Err.Number <> 0 Then
'If the sheet not exist in the workbook the row color will
be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If

End Sub



I appreciate your help.

Frank

 

[Frank Situmorang]

Ron:

I tried to search similar case, but with addtion password in the VBA. this
is what I found. How can we combine this VBA with yours to meet my
requirement>
Dim wkbk as workbook

set wkbk = Workbooks.Open Filename:="C:\book1.xls", Password:="a", _
writerespassword:="b", ignorereadonlyrecommended:=True

Thanks very much.

Frank

 

[Dave Peterson]

Check your other post.

Ron:

I tried to search similar case, but with addtion password in the VBA. this
is what I found. How can we combine this VBA with yours to meet my
requirement>
Dim wkbk as workbook

set wkbk = Workbooks.Open Filename:="C:\book1.xls", Password:="a", _
writerespassword:="b", ignorereadonlyrecommended:=True

Thanks very much.

Frank